c7dce08 · elk · git.iko.soy

compiler/Guid.hsdeleted−19

compare with master

unifiedsplit

@@ -1,19 +0,0 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−module Guid (guid, set, run, runAt, GuidCounter) where

3−

4−import Control.Monad.State (evalState, State, get, put)

5−

6−-- Wrapper around State monad.

7−newtype GuidCounter a = GC { runGC :: State Int a }

8− deriving (Monad)

9−

10−-- Get the next GUID, incrementing the counter.

11−guid :: GuidCounter Int

12−guid = GC $ do n <- get

13− put (n + 1)

14− return n

15−

16−set n = GC (put n)

17−

18−run = runAt 0

19−runAt n x = evalState (runGC x) n

compiler/Parse/Binop.hs+12−7

@@ -35,10 +35,10 @@ opAssoc :: OpTable -> String -> Assoc

35opAssoc table op = Map.findWithDefault R op dict

36 where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)

37

38−hasLevel :: OpTable -> Int -> (String,LExpr) -> Bool

38+hasLevel :: OpTable -> Int -> (String, LExpr t v) -> Bool

39hasLevel table n (op,_) = opLevel table op == n

40

41−binops :: OpTable -> IParser LExpr -> IParser String -> IParser LExpr

41+binops :: OpTable -> IParser (LExpr t v) -> IParser String -> IParser (LExpr t v)

42binops table term anyOp =

43 do e <- term

44 split (table ++ preludeTable) 0 e =<< many nextOp

@@ -48,7 +48,11 @@ binops table term anyOp =

48 whitespace ; e <- term

49 return (op,e)

50

51−split :: OpTable -> Int -> LExpr -> [(String, LExpr)] -> IParser LExpr

51+split :: OpTable

52+ -> Int

53+ -> LExpr t v

54+ -> [(String, LExpr t v)]

55+ -> IParser (LExpr t v)

52split _ _ e [] = return e

56split _ _ e [] = return e

53split table n e eops = do

57split table n e eops = do

54 assoc <- getAssoc table n eops

58 assoc <- getAssoc table n eops

@@ -57,25 +61,26 @@ split table n e eops = do

57 case assoc of R -> joinR es ops

61 case assoc of R -> joinR es ops

58 _ -> joinL es ops

62 _ -> joinL es ops

59

63

60−splitLevel :: OpTable -> Int -> LExpr -> [(String, LExpr)] -> [IParser LExpr]

64+splitLevel :: OpTable -> Int -> LExpr t v -> [(String, LExpr t v)]

65+ -> [IParser (LExpr t v)]

61splitLevel table n e eops =

66splitLevel table n e eops =

62 case break (hasLevel table n) eops of

67 case break (hasLevel table n) eops of

63 (lops, (op,e'):rops) ->

68 (lops, (op,e'):rops) ->

64 split table (n+1) e lops : splitLevel table n e' rops

69 split table (n+1) e lops : splitLevel table n e' rops

65 (lops, []) -> [ split table (n+1) e lops ]

70 (lops, []) -> [ split table (n+1) e lops ]

66

71

67−joinL :: [LExpr] -> [String] -> IParser LExpr

72+joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)

68joinL [e] [] = return e

73joinL [e] [] = return e

69joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops

74joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops

70joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."

75joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."

71

76

72−joinR :: [LExpr] -> [String] -> IParser LExpr

77+joinR :: [LExpr t v] -> [String] -> IParser (LExpr t v)

73joinR [e] [] = return e

78joinR [e] [] = return e

74joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

79joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

75 return (merge a e (Binop op a e))

80 return (merge a e (Binop op a e))

76joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."

81joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."

77

82

78−getAssoc :: OpTable -> Int -> [(String,LExpr)] -> IParser Assoc

83+getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc

79getAssoc table n eops

84getAssoc table n eops

80 | all (==L) assocs = return L

85 | all (==L) assocs = return L

81 | all (==R) assocs = return R

86 | all (==R) assocs = return R

compiler/Parse/Expression.hs+15−15

@@ -18,7 +18,7 @@ import qualified SourceSyntax.Literal as Literal

18import SourceSyntax.Expression

19import SourceSyntax.Declaration (Declaration(Definition))

20

21−import Guid

21+import Unique

22import Types.Types (Type (VarT), Scheme (Forall))

23

24import System.IO.Unsafe

@@ -26,14 +26,14 @@ import System.IO.Unsafe

26

27-------- Basic Terms --------

28

29−varTerm :: IParser Expr

29+varTerm :: IParser (Expr t v)

30varTerm = toVar <$> var <?> "variable"

31

32toVar v = case v of "True" -> Literal (Literal.Boolean True)

33 "False" -> Literal (Literal.Boolean False)

34 _ -> Var v

35

36−accessor :: IParser Expr

36+accessor :: IParser (Expr t v)

37accessor = do

38 start <- getPosition

39 lbl <- try (string "." >> rLabel)

@@ -44,7 +44,7 @@ accessor = do

44

45-------- Complex Terms --------

46

47−listTerm :: IParser Expr

47+listTerm :: IParser (Expr t v)

48listTerm =

49 (do { try $ string "[markdown|"

50 ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")

@@ -56,7 +56,7 @@ listTerm =

56 return e

57 ])

58

59−parensTerm :: IParser LExpr

59+parensTerm :: IParser (LExpr t v)

60parensTerm = parens $ choice

61 [ do start <- getPosition

62 op <- try anyOp

@@ -79,7 +79,7 @@ parensTerm = parens $ choice

79 _ -> Location.at start end (tuple es)

80 ]

81

82−recordTerm :: IParser LExpr

82+recordTerm :: IParser (LExpr t v)

83recordTerm = brackets $ choice [ misc, addLocation record ]

84 where field = do

85 fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix Pattern.term

@@ -111,14 +111,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]

111 Nothing -> try (insert record) <|> try (modify record)

112

113

114−term :: IParser LExpr

114+term :: IParser (LExpr t v)

115term = addLocation (choice [ Literal <$> literal, listTerm, accessor ])

116 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

117 <?> "basic term (4, x, 'c', etc.)"

118

119-------- Applications --------

120

121−appExpr :: IParser LExpr

121+appExpr :: IParser (LExpr t v)

122appExpr = do

123 tlist <- spaceSep1 term

124 return $ case tlist of

@@ -127,10 +127,10 @@ appExpr = do

127

128-------- Normal Expressions --------

129

130−binaryExpr :: IParser LExpr

130+binaryExpr :: IParser (LExpr t v)

131binaryExpr = binops [] appExpr anyOp

132

133−ifExpr :: IParser Expr

133+ifExpr :: IParser (Expr t v)

134ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

135 where

136 normal = do

@@ -145,7 +145,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

145 b <- expr ; whitespace ; string "->" ; whitespace

146 (,) b <$> expr

147

148−lambdaExpr :: IParser LExpr

148+lambdaExpr :: IParser (LExpr t v)

149lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

150 whitespace

151 pats <- spaceSep1 Pattern.term

@@ -153,17 +153,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

153 e <- expr

154 return . run $ Pattern.makeLambda pats e

155

156−defSet :: IParser [Def]

156+defSet :: IParser [Def t v]

157defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)

158

159−letExpr :: IParser Expr

159+letExpr :: IParser (Expr t v)

160letExpr = do

161 reserved "let" ; whitespace

162 defs <- defSet

163 whitespace ; reserved "in" ; whitespace

164 Let defs <$> expr

165

166−caseExpr :: IParser Expr

166+caseExpr :: IParser (Expr t v)

167caseExpr = do

168 reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace

169 Case e <$> (with <|> without)

@@ -189,7 +189,7 @@ funcDef = try (do p1 <- try Pattern.term ; infics p1 <|> func p1)

189 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

190 else [ PVar (o:p), p1, p2 ]

191

192−assignExpr :: IParser [Def]

192+assignExpr :: IParser [Def t v]

193assignExpr = withPos $ do

194 fDefs <- funcDef

195 whitespace

compiler/Parse/Foreign.hs+3−3

@@ -10,11 +10,11 @@ import Parse.Expression (term)

10import Parse.Type

11import Types.Types (signalOf)

12

13−foreignDef :: IParser Declaration

13+foreignDef :: IParser (Declaration t v)

14foreignDef = do try (reserved "foreign") ; whitespace

15 importEvent <|> exportEvent

16

17−exportEvent :: IParser Declaration

17+exportEvent :: IParser (Declaration t v)

18exportEvent = do

19 try (reserved "export") >> whitespace >> reserved "jsevent" >> whitespace

20 js <- jsVar ; whitespace

@@ -26,7 +26,7 @@ exportEvent = do

26 either error (return . ExportEvent js elm . signalOf) (toForeignType pt)

27 _ -> error "When exporting events, the exported value must be a Signal."

28

29−importEvent :: IParser Declaration

29+importEvent :: IParser (Declaration t v)

30importEvent = do

31 try (reserved "import") >> whitespace >> reserved "jsevent" >> whitespace

32 js <- jsVar ; whitespace

compiler/Parse/Helpers.hs+2−2

@@ -124,14 +124,14 @@ parens = surround '(' ')' "paren"

124brackets :: IParser a -> IParser a

125brackets = surround '{' '}' "bracket"

126

127−addLocation :: IParser Expr -> IParser LExpr

127+addLocation :: IParser (Expr t v) -> IParser (LExpr t v)

128addLocation expr = do

129 start <- getPosition

130 e <- expr

131 end <- getPosition

132 return (Location.at start end e)

133

134−accessible :: IParser LExpr -> IParser LExpr

134+accessible :: IParser (LExpr t v) -> IParser (LExpr t v)

135accessible expr = do

136 start <- getPosition

137 ce@(L s t e) <- expr

compiler/Parse/Parser.hs+6−6

@@ -1,17 +1,17 @@

1module Parse.Parser (parseProgram, parseDependencies, parseInfix) where

2

3−import Ast

3+import SourceSyntax.Module

4import Control.Applicative ((<$>), (<*>))

5import Control.Monad

6import Data.Char (isSymbol, isDigit)

7import Data.List (foldl',intercalate)

8import Text.Parsec hiding (newline,spaces)

9

10−import Parse.Library

10+import Parse.Helpers

11−import Parse.Binops (infixStmt, OpTable)

11+import Parse.Binop (infixStmt, OpTable)

12−import Parse.Expr

12+import Parse.Expression

13−import Parse.Types

13+import Parse.Type

14−import Parse.Modules

14+import Parse.Module

15import Parse.Foreign

16

17statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"

compiler/Parse/Pattern.hs+6−6

@@ -5,7 +5,7 @@ import Control.Applicative ((<$>),(<*>),(*>),pure)

5import Control.Monad

6import Control.Monad.State

7import Data.Char (isUpper)

8−import Guid

8+import Unique

9import Text.Parsec hiding (newline,spaces,State)

10import Text.Parsec.Indent

11import Parse.Helpers

@@ -51,14 +51,14 @@ expr = do

51 patterns <- consSep1 (patternConstructor <|> term)

52 asPattern (foldr1 Pattern.cons patterns) <?> "pattern"

53

54−makeLambda :: [Pattern] -> LExpr -> GuidCounter LExpr

54+makeLambda :: [Pattern] -> LExpr t v -> Unique (LExpr t v)

55makeLambda pats body = go (reverse pats) body

56 where go [] body = return body

57 go (p:ps) body@(L t s _) = do

58 (x,e) <- extract p body

59 go ps (L t s $ Lambda x e)

60

61−extract :: Pattern -> LExpr -> GuidCounter (String, LExpr)

61+extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)

62extract pattern body@(L t s _) =

63 let loc = L t s in

64 let fn x e = (x,e) in

@@ -79,13 +79,13 @@ extract pattern body@(L t s _) =

79 toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

80 return . fn a . loc $ Let (map toDef fs) body

81

82−extracts :: [Pattern] -> LExpr -> GuidCounter ([String], LExpr)

82+extracts :: [Pattern] -> LExpr t v -> Unique ([String], LExpr t v)

83extracts ps body = go [] (reverse ps) body

84 where go args [] body = return (args, body)

85 go args (p:ps) body = do (x,e) <- extract p body

86 go (x:args) ps e

87

88−flatten :: [Pattern] -> LExpr -> GuidCounter (IParser [Def])

88+flatten :: [Pattern] -> LExpr t v -> Unique (IParser [Def t v])

89flatten patterns exp@(L t s _) =

90 let loc = L t s in

91 case patterns of

@@ -100,7 +100,7 @@ flatten patterns exp@(L t s _) =

100 _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++

101 ") cannot be used on the left-hand side of an assign statement."

102

103−matchSingle :: Pattern -> LExpr -> Pattern -> GuidCounter [Def]

103+matchSingle :: Pattern -> LExpr t v -> Pattern -> Unique [Def t v]

104matchSingle pat exp@(L t s _) p =

105 let loc = L t s in

106 case p of

compiler/Parse/Type.hs+4−4

@@ -12,7 +12,7 @@ import SourceSyntax.Expression

12import SourceSyntax.Declaration

13import Parse.Helpers

14import Types.Types hiding (parens,string)

15−import Guid

15+import Unique

16

17data ParseType = VarPT String

18 | LambdaPT ParseType ParseType

@@ -69,7 +69,7 @@ typeConstructor :: IParser (String, [ParseType])

69typeConstructor = (,) <$> (capVar <?> "another type constructor")

70 <*> spacePrefix (typeSimple <|> typeUnambiguous)

71

72−typeAlias :: IParser [Declaration]

72+typeAlias :: IParser [Declaration t v]

73typeAlias = do

74 start <- getPosition

75 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

@@ -102,12 +102,12 @@ toConstructor start end alias (Just _) kvs =

102 rec = foldl insert (Var "_ext_") (zip args (map (loc . Var) args))

103 insert e (k,v) = Insert (loc e) k v

104

105−annotation :: IParser Def

105+annotation :: IParser (Def t v)

106annotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)

107 where start = do v <- lowVar <|> parens symOp

108 whitespace ; hasType ; whitespace ; return v

109

110−datatype :: IParser Declaration

110+datatype :: IParser (Declaration t v)

111datatype = do

112 reserved "data" <?> "datatype definition (data T = A | B | ...)"

113 forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar

compiler/SourceSyntax/Declaration.hs+3−3

@@ -5,11 +5,11 @@ import Data.Data

5import qualified SourceSyntax.Expression as Expr

6import Types.Types

7

8−data Declaration

8+data Declaration tipe var

9− = Definition Expr.Def

9+ = Definition (Expr.Def tipe var)

10 | Datatype String [X] [(String,[Type])]

11 | TypeAlias String [X] Type

12− | ImportEvent String Expr.LExpr String Type

12+ | ImportEvent String (Expr.LExpr tipe var) String Type

13 | ExportEvent String String Type

14 | Fixity Assoc Int String

15 deriving (Eq, Show, Data, Typeable)

compiler/SourceSyntax/Expression.hs+26−24

@@ -10,29 +10,31 @@ import qualified SourceSyntax.Pattern as Pattern

10import qualified SourceSyntax.Literal as Literal

11import Types.Types

12

13−type LExpr = Location.Located Expr

13+type LExpr tipe var = Location.Located (Expr tipe var)

14+data Expr t v

14−data Expr = Literal Literal.Literal

15+ = Literal Literal.Literal

16+ | Var String

15− | Range LExpr LExpr

17+ | Range (LExpr t v) (LExpr t v)

16− | Access LExpr String

18+ | Access (LExpr t v) String

17− | Remove LExpr String

19+ | Remove (LExpr t v) String

18− | Insert LExpr String LExpr

20+ | Insert (LExpr t v) String (LExpr t v)

19− | Modify LExpr [(String,LExpr)]

21+ | Modify (LExpr t v) [(String, LExpr t v)]

20− | Record [(String,[String],LExpr)]

22+ | Record [(String, [String], LExpr t v)]

21− | Binop String LExpr LExpr

23+ | Binop String (LExpr t v) (LExpr t v)

22− | Lambda String LExpr

24+ | Lambda String (LExpr t v)

23− | App LExpr LExpr

25+ | App (LExpr t v) (LExpr t v)

24− | MultiIf [(LExpr,LExpr)]

26+ | MultiIf [(LExpr t v,LExpr t v)]

25− | Let [Def] LExpr

27+ | Let [Def t v] (LExpr t v)

26− | Var String

27− | Case LExpr [(Pattern.Pattern,LExpr)]

28+ | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]

28− | Data String [LExpr]

29+ | Data String [LExpr t v]

29− | Markdown Pandoc.Pandoc

30+ | Markdown Pandoc.Pandoc

30− deriving (Eq, Data, Typeable)

31+ deriving (Eq, Data, Typeable)

31

32

33+data Def tipe var

32−data Def = FnDef String [String] LExpr

34+ = FnDef String [String] (LExpr tipe var)

33− | OpDef String String String LExpr

35+ | OpDef String String String (LExpr tipe var)

34− | TypeAnnotation String Type

36+ | TypeAnnotation String Type

35− deriving (Eq, Data, Typeable)

37+ deriving (Eq, Data, Typeable)

36

38

37cons h t = Location.merge h t (Data "Cons" [h,t])

39cons h t = Location.merge h t (Data "Cons" [h,t])

38nil = Location.L (Just "[]") Location.NoSpan (Data "Nil" [])

40nil = Location.L (Just "[]") Location.NoSpan (Data "Nil" [])

@@ -43,7 +45,7 @@ delist (Location.L _ _ (Data "Cons" [h,t])) = h : delist t

43delist _ = []

45delist _ = []

44

46

45

47

46−instance Show Expr where

48+instance Show (Expr t v) where

47 show e =

49 show e =

48 let show' (Location.L _ _ e) = Help.parensIf (needsParens e) (show e) in

50 let show' (Location.L _ _ e) = Help.parensIf (needsParens e) (show e) in

49 case e of

51 case e of

@@ -77,7 +79,7 @@ instance Show Expr where

77 Markdown _ -> "[markdown| ... |]"

79 Markdown _ -> "[markdown| ... |]"

78

80

79

81

80−instance Show Def where

82+instance Show (Def t v) where

81 show e =

83 show e =

82 case e of

84 case e of

83 FnDef v [] e -> v ++ " = " ++ show e

85 FnDef v [] e -> v ++ " = " ++ show e

compiler/SourceSyntax/Module.hs+5−4

@@ -7,8 +7,9 @@ import qualified SourceSyntax.Declaration as Decl

7import System.FilePath (joinPath)

8import Types.Types

9

10+data Module tipe var =

10−data Module = Module [String] Exports Imports [Decl.Declaration]

11+ Module [String] Exports Imports [Decl.Declaration tipe var]

11− deriving (Show)

12+ deriving (Show)

12

13

13type Exports = [String]

14type Exports = [String]

14

15

@@ -16,8 +17,8 @@ type Imports = [(String, ImportMethod)]

16data ImportMethod = As String | Importing [String] | Hiding [String]

17data ImportMethod = As String | Importing [String] | Hiding [String]

17 deriving (Eq, Ord, Show, Data, Typeable)

18 deriving (Eq, Ord, Show, Data, Typeable)

18

19

19−name :: Module -> String

20+name :: Module a b -> String

20name (Module names _ _ _) = intercalate "." names

21name (Module names _ _ _) = intercalate "." names

21

22

22−path :: Module -> FilePath

23+path :: Module a b -> FilePath

23path (Module names _ _ _) = joinPath names

24path (Module names _ _ _) = joinPath names

compiler/SourceSyntax/Rename.hs+12−12

@@ -5,7 +5,7 @@ import Control.Arrow (first)

5import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)

6import Control.Monad.State (evalState, State, get, put)

7import Data.Char (isLower,isDigit)

8−import Guid

8+import Unique

9import SourceSyntax.Location

10import SourceSyntax.Pattern

11import SourceSyntax.Expression

@@ -16,17 +16,17 @@ derename var

16 | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var

17 | otherwise = var

18

19−renameModule :: Module -> Module

19+renameModule :: Module t v -> Module t v

20renameModule modul = run (rename deprime modul)

21

22class Rename a where

23− rename :: (String -> String) -> a -> GuidCounter a

23+ rename :: (String -> String) -> a -> Unique a

24

25−instance Rename Module where

25+instance Rename (Module t v) where

26 rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts

27 return (Module name ex im stmts')

28

29−instance Rename Def where

29+instance Rename (Def t v) where

30 rename env (OpDef op a1 a2 e) =

31 do env' <- extends env [a1,a2]

32 OpDef op (env' a1) (env' a2) `liftM` rename env' e

@@ -36,7 +36,7 @@ instance Rename Def where

36 rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)

37

38

39−instance Rename Declaration where

39+instance Rename (Declaration t v) where

40 rename env stmt =

41 case stmt of

42 Definition def -> Definition `liftM` rename env def

@@ -60,7 +60,7 @@ renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts

60instance Rename a => Rename (Located a) where

61 rename env (L t s e) = L t s `liftM` rename env e

62

63−instance Rename Expr where

63+instance Rename (Expr t v) where

64 rename env expr =

65 let rnm = rename env in

66 case expr of

@@ -115,16 +115,16 @@ instance Rename Expr where

115

116deprime = map (\c -> if c == '\'' then '$' else c)

117

118−extend :: (String -> String) -> String -> GuidCounter (String, String -> String)

118+extend :: (String -> String) -> String -> Unique (String, String -> String)

119extend env x = do

120 n <- guid

121 let rx = deprime x ++ "_" ++ show n

122 return (rx, \y -> if y == x then rx else env y)

123

124−extends :: (String -> String) -> [String] -> GuidCounter (String -> String)

124+extends :: (String -> String) -> [String] -> Unique (String -> String)

125extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs

126

127−patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)

127+patternExtend :: Pattern -> (String -> String) -> Unique (Pattern, String -> String)

128patternExtend pattern env =

129 case pattern of

130 PAnything -> return (PAnything, env)

@@ -141,8 +141,8 @@ patternExtend pattern env =

141 return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)

142

143patternRename :: (String -> String)

144− -> (Pattern, LExpr)

144+ -> (Pattern, LExpr t v)

145− -> GuidCounter (Pattern, LExpr)

145+ -> Unique (Pattern, LExpr t v)

146patternRename env (p,e) = do

147 (rp,env') <- patternExtend p env

148 re <- rename env' e

compiler/Unique.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+module Unique (guid, set, run, runAt, Unique) where

3+

4+import Control.Monad.State (evalState, State, get, put)

5+

6+-- Wrapper around State monad.

7+newtype Unique a = U { runU :: State Int a }

8+ deriving (Monad)

9+

10+-- Get the next GUID, incrementing the counter.

11+guid :: Unique Int

12+guid = U $ do n <- get

13+ put (n + 1)

14+ return n

15+

16+set n = U (put n)

17+

18+run = runAt 0

19+runAt n x = evalState (runU x) n