Label.hs 1.19 KB
Newer Older
1
{-# LANGUAGE OverloadedStrings #-}
2
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
Sven Keidel's avatar
Sven Keidel committed
3
{-# LANGUAGE MultiParamTypeClasses #-}
Sven Keidel's avatar
Sven Keidel committed
4
{-# LANGUAGE FlexibleInstances #-}
5
{-# LANGUAGE FlexibleContexts #-}
Tomislav Pree's avatar
Tomislav Pree committed
6
{-# LANGUAGE DeriveGeneric #-}
Sven Keidel's avatar
Sven Keidel committed
7
8
module Data.Label where

9
import Data.Hashable
Sven Keidel's avatar
Sven Keidel committed
10
11
import Data.Order
import Data.Abstract.FreeCompletion
12
import Control.Monad.State
13
import Control.DeepSeq
Sven Keidel's avatar
Sven Keidel committed
14
import Text.Printf
15
import Data.Text.Prettyprint.Doc
16

Tomislav Pree's avatar
Tomislav Pree committed
17
18
19
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics

Sven Keidel's avatar
Sven Keidel committed
20
-- Retrieves label from expression.
Sven Keidel's avatar
Sven Keidel committed
21
22
class HasLabel x where
  label :: x -> Label
23
24

newtype Label = Label { labelVal :: Int }
Tomislav Pree's avatar
Tomislav Pree committed
25
  deriving (Ord,Eq,Hashable,Num,NFData,Generic,ToJSON,FromJSON)
26
27

instance Show Label where
Sven Keidel's avatar
Sven Keidel committed
28
  show (Label l) = printf "#%d" l
29

30
31
32
instance Pretty Label where
  pretty (Label l) = "#" <> pretty l

Sven Keidel's avatar
Sven Keidel committed
33
34
35
36
37
38
39
instance PreOrd Label where
  () = (==)

instance Complete (FreeCompletion Label) where
  Lower l1  Lower l2 | l1 == l2 = Lower l1
  _  _ = Top

40
41
42
instance UpperBounded (FreeCompletion Label) where
  top = Top

43
fresh :: MonadState Label m => m Label
44
45
46
47
fresh = state (\l -> (l,l+1))

generate :: State Label x -> x
generate m = evalState m 0
48
49
50

generate' :: Monad m => StateT Label m x -> m x
generate' m = evalStateT m 0