Parameterized the AST for type annotations and variable types. Also rename Guid.hs to Unique.hs which reads a lot nicer.
This commit is contained in:
evancz
parent
459cf8ec73
commit
c7dce08193
13 changed files with 113 additions and 105 deletions
|
|
@ -1,19 +0,0 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module Guid (guid, set, run, runAt, GuidCounter) where
|
||||
|
||||
import Control.Monad.State (evalState, State, get, put)
|
||||
|
||||
-- Wrapper around State monad.
|
||||
newtype GuidCounter a = GC { runGC :: State Int a }
|
||||
deriving (Monad)
|
||||
|
||||
-- Get the next GUID, incrementing the counter.
|
||||
guid :: GuidCounter Int
|
||||
guid = GC $ do n <- get
|
||||
put (n + 1)
|
||||
return n
|
||||
|
||||
set n = GC (put n)
|
||||
|
||||
run = runAt 0
|
||||
runAt n x = evalState (runGC x) n
|
||||
|
|
@ -35,10 +35,10 @@ opAssoc :: OpTable -> String -> Assoc
|
|||
opAssoc table op = Map.findWithDefault R op dict
|
||||
where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)
|
||||
|
||||
hasLevel :: OpTable -> Int -> (String,LExpr) -> Bool
|
||||
hasLevel :: OpTable -> Int -> (String, LExpr t v) -> Bool
|
||||
hasLevel table n (op,_) = opLevel table op == n
|
||||
|
||||
binops :: OpTable -> IParser LExpr -> IParser String -> IParser LExpr
|
||||
binops :: OpTable -> IParser (LExpr t v) -> IParser String -> IParser (LExpr t v)
|
||||
binops table term anyOp =
|
||||
do e <- term
|
||||
split (table ++ preludeTable) 0 e =<< many nextOp
|
||||
|
|
@ -48,7 +48,11 @@ binops table term anyOp =
|
|||
whitespace ; e <- term
|
||||
return (op,e)
|
||||
|
||||
split :: OpTable -> Int -> LExpr -> [(String, LExpr)] -> IParser LExpr
|
||||
split :: OpTable
|
||||
-> Int
|
||||
-> LExpr t v
|
||||
-> [(String, LExpr t v)]
|
||||
-> IParser (LExpr t v)
|
||||
split _ _ e [] = return e
|
||||
split table n e eops = do
|
||||
assoc <- getAssoc table n eops
|
||||
|
|
@ -57,25 +61,26 @@ split table n e eops = do
|
|||
case assoc of R -> joinR es ops
|
||||
_ -> joinL es ops
|
||||
|
||||
splitLevel :: OpTable -> Int -> LExpr -> [(String, LExpr)] -> [IParser LExpr]
|
||||
splitLevel :: OpTable -> Int -> LExpr t v -> [(String, LExpr t v)]
|
||||
-> [IParser (LExpr t v)]
|
||||
splitLevel table n e eops =
|
||||
case break (hasLevel table n) eops of
|
||||
(lops, (op,e'):rops) ->
|
||||
split table (n+1) e lops : splitLevel table n e' rops
|
||||
(lops, []) -> [ split table (n+1) e lops ]
|
||||
|
||||
joinL :: [LExpr] -> [String] -> IParser LExpr
|
||||
joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)
|
||||
joinL [e] [] = return e
|
||||
joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops
|
||||
joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."
|
||||
|
||||
joinR :: [LExpr] -> [String] -> IParser LExpr
|
||||
joinR :: [LExpr t v] -> [String] -> IParser (LExpr t v)
|
||||
joinR [e] [] = return e
|
||||
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
|
||||
return (merge a e (Binop op a e))
|
||||
joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
|
||||
|
||||
getAssoc :: OpTable -> Int -> [(String,LExpr)] -> IParser Assoc
|
||||
getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc
|
||||
getAssoc table n eops
|
||||
| all (==L) assocs = return L
|
||||
| all (==R) assocs = return R
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ import qualified SourceSyntax.Literal as Literal
|
|||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Declaration (Declaration(Definition))
|
||||
|
||||
import Guid
|
||||
import Unique
|
||||
import Types.Types (Type (VarT), Scheme (Forall))
|
||||
|
||||
import System.IO.Unsafe
|
||||
|
|
@ -26,14 +26,14 @@ import System.IO.Unsafe
|
|||
|
||||
-------- Basic Terms --------
|
||||
|
||||
varTerm :: IParser Expr
|
||||
varTerm :: IParser (Expr t v)
|
||||
varTerm = toVar <$> var <?> "variable"
|
||||
|
||||
toVar v = case v of "True" -> Literal (Literal.Boolean True)
|
||||
"False" -> Literal (Literal.Boolean False)
|
||||
_ -> Var v
|
||||
|
||||
accessor :: IParser Expr
|
||||
accessor :: IParser (Expr t v)
|
||||
accessor = do
|
||||
start <- getPosition
|
||||
lbl <- try (string "." >> rLabel)
|
||||
|
|
@ -44,7 +44,7 @@ accessor = do
|
|||
|
||||
-------- Complex Terms --------
|
||||
|
||||
listTerm :: IParser Expr
|
||||
listTerm :: IParser (Expr t v)
|
||||
listTerm =
|
||||
(do { try $ string "[markdown|"
|
||||
; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
|
||||
|
|
@ -56,7 +56,7 @@ listTerm =
|
|||
return e
|
||||
])
|
||||
|
||||
parensTerm :: IParser LExpr
|
||||
parensTerm :: IParser (LExpr t v)
|
||||
parensTerm = parens $ choice
|
||||
[ do start <- getPosition
|
||||
op <- try anyOp
|
||||
|
|
@ -79,7 +79,7 @@ parensTerm = parens $ choice
|
|||
_ -> Location.at start end (tuple es)
|
||||
]
|
||||
|
||||
recordTerm :: IParser LExpr
|
||||
recordTerm :: IParser (LExpr t v)
|
||||
recordTerm = brackets $ choice [ misc, addLocation record ]
|
||||
where field = do
|
||||
fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix Pattern.term
|
||||
|
|
@ -111,14 +111,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]
|
|||
Nothing -> try (insert record) <|> try (modify record)
|
||||
|
||||
|
||||
term :: IParser LExpr
|
||||
term :: IParser (LExpr t v)
|
||||
term = addLocation (choice [ Literal <$> literal, listTerm, accessor ])
|
||||
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
|
||||
<?> "basic term (4, x, 'c', etc.)"
|
||||
|
||||
-------- Applications --------
|
||||
|
||||
appExpr :: IParser LExpr
|
||||
appExpr :: IParser (LExpr t v)
|
||||
appExpr = do
|
||||
tlist <- spaceSep1 term
|
||||
return $ case tlist of
|
||||
|
|
@ -127,10 +127,10 @@ appExpr = do
|
|||
|
||||
-------- Normal Expressions --------
|
||||
|
||||
binaryExpr :: IParser LExpr
|
||||
binaryExpr :: IParser (LExpr t v)
|
||||
binaryExpr = binops [] appExpr anyOp
|
||||
|
||||
ifExpr :: IParser Expr
|
||||
ifExpr :: IParser (Expr t v)
|
||||
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
|
||||
where
|
||||
normal = do
|
||||
|
|
@ -145,7 +145,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
|
|||
b <- expr ; whitespace ; string "->" ; whitespace
|
||||
(,) b <$> expr
|
||||
|
||||
lambdaExpr :: IParser LExpr
|
||||
lambdaExpr :: IParser (LExpr t v)
|
||||
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
||||
whitespace
|
||||
pats <- spaceSep1 Pattern.term
|
||||
|
|
@ -153,17 +153,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
|||
e <- expr
|
||||
return . run $ Pattern.makeLambda pats e
|
||||
|
||||
defSet :: IParser [Def]
|
||||
defSet :: IParser [Def t v]
|
||||
defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)
|
||||
|
||||
letExpr :: IParser Expr
|
||||
letExpr :: IParser (Expr t v)
|
||||
letExpr = do
|
||||
reserved "let" ; whitespace
|
||||
defs <- defSet
|
||||
whitespace ; reserved "in" ; whitespace
|
||||
Let defs <$> expr
|
||||
|
||||
caseExpr :: IParser Expr
|
||||
caseExpr :: IParser (Expr t v)
|
||||
caseExpr = do
|
||||
reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
|
||||
Case e <$> (with <|> without)
|
||||
|
|
@ -189,7 +189,7 @@ funcDef = try (do p1 <- try Pattern.term ; infics p1 <|> func p1)
|
|||
return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
|
||||
else [ PVar (o:p), p1, p2 ]
|
||||
|
||||
assignExpr :: IParser [Def]
|
||||
assignExpr :: IParser [Def t v]
|
||||
assignExpr = withPos $ do
|
||||
fDefs <- funcDef
|
||||
whitespace
|
||||
|
|
|
|||
|
|
@ -10,11 +10,11 @@ import Parse.Expression (term)
|
|||
import Parse.Type
|
||||
import Types.Types (signalOf)
|
||||
|
||||
foreignDef :: IParser Declaration
|
||||
foreignDef :: IParser (Declaration t v)
|
||||
foreignDef = do try (reserved "foreign") ; whitespace
|
||||
importEvent <|> exportEvent
|
||||
|
||||
exportEvent :: IParser Declaration
|
||||
exportEvent :: IParser (Declaration t v)
|
||||
exportEvent = do
|
||||
try (reserved "export") >> whitespace >> reserved "jsevent" >> whitespace
|
||||
js <- jsVar ; whitespace
|
||||
|
|
@ -26,7 +26,7 @@ exportEvent = do
|
|||
either error (return . ExportEvent js elm . signalOf) (toForeignType pt)
|
||||
_ -> error "When exporting events, the exported value must be a Signal."
|
||||
|
||||
importEvent :: IParser Declaration
|
||||
importEvent :: IParser (Declaration t v)
|
||||
importEvent = do
|
||||
try (reserved "import") >> whitespace >> reserved "jsevent" >> whitespace
|
||||
js <- jsVar ; whitespace
|
||||
|
|
|
|||
|
|
@ -124,14 +124,14 @@ parens = surround '(' ')' "paren"
|
|||
brackets :: IParser a -> IParser a
|
||||
brackets = surround '{' '}' "bracket"
|
||||
|
||||
addLocation :: IParser Expr -> IParser LExpr
|
||||
addLocation :: IParser (Expr t v) -> IParser (LExpr t v)
|
||||
addLocation expr = do
|
||||
start <- getPosition
|
||||
e <- expr
|
||||
end <- getPosition
|
||||
return (Location.at start end e)
|
||||
|
||||
accessible :: IParser LExpr -> IParser LExpr
|
||||
accessible :: IParser (LExpr t v) -> IParser (LExpr t v)
|
||||
accessible expr = do
|
||||
start <- getPosition
|
||||
ce@(L s t e) <- expr
|
||||
|
|
|
|||
|
|
@ -1,17 +1,17 @@
|
|||
module Parse.Parser (parseProgram, parseDependencies, parseInfix) where
|
||||
|
||||
import Ast
|
||||
import SourceSyntax.Module
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Monad
|
||||
import Data.Char (isSymbol, isDigit)
|
||||
import Data.List (foldl',intercalate)
|
||||
import Text.Parsec hiding (newline,spaces)
|
||||
|
||||
import Parse.Library
|
||||
import Parse.Binops (infixStmt, OpTable)
|
||||
import Parse.Expr
|
||||
import Parse.Types
|
||||
import Parse.Modules
|
||||
import Parse.Helpers
|
||||
import Parse.Binop (infixStmt, OpTable)
|
||||
import Parse.Expression
|
||||
import Parse.Type
|
||||
import Parse.Module
|
||||
import Parse.Foreign
|
||||
|
||||
statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ import Control.Applicative ((<$>),(<*>),(*>),pure)
|
|||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import Data.Char (isUpper)
|
||||
import Guid
|
||||
import Unique
|
||||
import Text.Parsec hiding (newline,spaces,State)
|
||||
import Text.Parsec.Indent
|
||||
import Parse.Helpers
|
||||
|
|
@ -51,14 +51,14 @@ expr = do
|
|||
patterns <- consSep1 (patternConstructor <|> term)
|
||||
asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
|
||||
|
||||
makeLambda :: [Pattern] -> LExpr -> GuidCounter LExpr
|
||||
makeLambda :: [Pattern] -> LExpr t v -> Unique (LExpr t v)
|
||||
makeLambda pats body = go (reverse pats) body
|
||||
where go [] body = return body
|
||||
go (p:ps) body@(L t s _) = do
|
||||
(x,e) <- extract p body
|
||||
go ps (L t s $ Lambda x e)
|
||||
|
||||
extract :: Pattern -> LExpr -> GuidCounter (String, LExpr)
|
||||
extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
|
||||
extract pattern body@(L t s _) =
|
||||
let loc = L t s in
|
||||
let fn x e = (x,e) in
|
||||
|
|
@ -79,13 +79,13 @@ extract pattern body@(L t s _) =
|
|||
toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
|
||||
return . fn a . loc $ Let (map toDef fs) body
|
||||
|
||||
extracts :: [Pattern] -> LExpr -> GuidCounter ([String], LExpr)
|
||||
extracts :: [Pattern] -> LExpr t v -> Unique ([String], LExpr t v)
|
||||
extracts ps body = go [] (reverse ps) body
|
||||
where go args [] body = return (args, body)
|
||||
go args (p:ps) body = do (x,e) <- extract p body
|
||||
go (x:args) ps e
|
||||
|
||||
flatten :: [Pattern] -> LExpr -> GuidCounter (IParser [Def])
|
||||
flatten :: [Pattern] -> LExpr t v -> Unique (IParser [Def t v])
|
||||
flatten patterns exp@(L t s _) =
|
||||
let loc = L t s in
|
||||
case patterns of
|
||||
|
|
@ -100,7 +100,7 @@ flatten patterns exp@(L t s _) =
|
|||
_ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++
|
||||
") cannot be used on the left-hand side of an assign statement."
|
||||
|
||||
matchSingle :: Pattern -> LExpr -> Pattern -> GuidCounter [Def]
|
||||
matchSingle :: Pattern -> LExpr t v -> Pattern -> Unique [Def t v]
|
||||
matchSingle pat exp@(L t s _) p =
|
||||
let loc = L t s in
|
||||
case p of
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ import SourceSyntax.Expression
|
|||
import SourceSyntax.Declaration
|
||||
import Parse.Helpers
|
||||
import Types.Types hiding (parens,string)
|
||||
import Guid
|
||||
import Unique
|
||||
|
||||
data ParseType = VarPT String
|
||||
| LambdaPT ParseType ParseType
|
||||
|
|
@ -69,7 +69,7 @@ typeConstructor :: IParser (String, [ParseType])
|
|||
typeConstructor = (,) <$> (capVar <?> "another type constructor")
|
||||
<*> spacePrefix (typeSimple <|> typeUnambiguous)
|
||||
|
||||
typeAlias :: IParser [Declaration]
|
||||
typeAlias :: IParser [Declaration t v]
|
||||
typeAlias = do
|
||||
start <- getPosition
|
||||
reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
|
||||
|
|
@ -102,12 +102,12 @@ toConstructor start end alias (Just _) kvs =
|
|||
rec = foldl insert (Var "_ext_") (zip args (map (loc . Var) args))
|
||||
insert e (k,v) = Insert (loc e) k v
|
||||
|
||||
annotation :: IParser Def
|
||||
annotation :: IParser (Def t v)
|
||||
annotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
|
||||
where start = do v <- lowVar <|> parens symOp
|
||||
whitespace ; hasType ; whitespace ; return v
|
||||
|
||||
datatype :: IParser Declaration
|
||||
datatype :: IParser (Declaration t v)
|
||||
datatype = do
|
||||
reserved "data" <?> "datatype definition (data T = A | B | ...)"
|
||||
forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar
|
||||
|
|
|
|||
|
|
@ -5,11 +5,11 @@ import Data.Data
|
|||
import qualified SourceSyntax.Expression as Expr
|
||||
import Types.Types
|
||||
|
||||
data Declaration
|
||||
= Definition Expr.Def
|
||||
data Declaration tipe var
|
||||
= Definition (Expr.Def tipe var)
|
||||
| Datatype String [X] [(String,[Type])]
|
||||
| TypeAlias String [X] Type
|
||||
| ImportEvent String Expr.LExpr String Type
|
||||
| ImportEvent String (Expr.LExpr tipe var) String Type
|
||||
| ExportEvent String String Type
|
||||
| Fixity Assoc Int String
|
||||
deriving (Eq, Show, Data, Typeable)
|
||||
|
|
|
|||
|
|
@ -10,29 +10,31 @@ import qualified SourceSyntax.Pattern as Pattern
|
|||
import qualified SourceSyntax.Literal as Literal
|
||||
import Types.Types
|
||||
|
||||
type LExpr = Location.Located Expr
|
||||
data Expr = Literal Literal.Literal
|
||||
| Range LExpr LExpr
|
||||
| Access LExpr String
|
||||
| Remove LExpr String
|
||||
| Insert LExpr String LExpr
|
||||
| Modify LExpr [(String,LExpr)]
|
||||
| Record [(String,[String],LExpr)]
|
||||
| Binop String LExpr LExpr
|
||||
| Lambda String LExpr
|
||||
| App LExpr LExpr
|
||||
| MultiIf [(LExpr,LExpr)]
|
||||
| Let [Def] LExpr
|
||||
| Var String
|
||||
| Case LExpr [(Pattern.Pattern,LExpr)]
|
||||
| Data String [LExpr]
|
||||
| Markdown Pandoc.Pandoc
|
||||
deriving (Eq, Data, Typeable)
|
||||
type LExpr tipe var = Location.Located (Expr tipe var)
|
||||
data Expr t v
|
||||
= Literal Literal.Literal
|
||||
| Var String
|
||||
| Range (LExpr t v) (LExpr t v)
|
||||
| Access (LExpr t v) String
|
||||
| Remove (LExpr t v) String
|
||||
| Insert (LExpr t v) String (LExpr t v)
|
||||
| Modify (LExpr t v) [(String, LExpr t v)]
|
||||
| Record [(String, [String], LExpr t v)]
|
||||
| Binop String (LExpr t v) (LExpr t v)
|
||||
| Lambda String (LExpr t v)
|
||||
| App (LExpr t v) (LExpr t v)
|
||||
| MultiIf [(LExpr t v,LExpr t v)]
|
||||
| Let [Def t v] (LExpr t v)
|
||||
| Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]
|
||||
| Data String [LExpr t v]
|
||||
| Markdown Pandoc.Pandoc
|
||||
deriving (Eq, Data, Typeable)
|
||||
|
||||
data Def = FnDef String [String] LExpr
|
||||
| OpDef String String String LExpr
|
||||
| TypeAnnotation String Type
|
||||
deriving (Eq, Data, Typeable)
|
||||
data Def tipe var
|
||||
= FnDef String [String] (LExpr tipe var)
|
||||
| OpDef String String String (LExpr tipe var)
|
||||
| TypeAnnotation String Type
|
||||
deriving (Eq, Data, Typeable)
|
||||
|
||||
cons h t = Location.merge h t (Data "Cons" [h,t])
|
||||
nil = Location.L (Just "[]") Location.NoSpan (Data "Nil" [])
|
||||
|
|
@ -43,7 +45,7 @@ delist (Location.L _ _ (Data "Cons" [h,t])) = h : delist t
|
|||
delist _ = []
|
||||
|
||||
|
||||
instance Show Expr where
|
||||
instance Show (Expr t v) where
|
||||
show e =
|
||||
let show' (Location.L _ _ e) = Help.parensIf (needsParens e) (show e) in
|
||||
case e of
|
||||
|
|
@ -77,7 +79,7 @@ instance Show Expr where
|
|||
Markdown _ -> "[markdown| ... |]"
|
||||
|
||||
|
||||
instance Show Def where
|
||||
instance Show (Def t v) where
|
||||
show e =
|
||||
case e of
|
||||
FnDef v [] e -> v ++ " = " ++ show e
|
||||
|
|
|
|||
|
|
@ -7,8 +7,9 @@ import qualified SourceSyntax.Declaration as Decl
|
|||
import System.FilePath (joinPath)
|
||||
import Types.Types
|
||||
|
||||
data Module = Module [String] Exports Imports [Decl.Declaration]
|
||||
deriving (Show)
|
||||
data Module tipe var =
|
||||
Module [String] Exports Imports [Decl.Declaration tipe var]
|
||||
deriving (Show)
|
||||
|
||||
type Exports = [String]
|
||||
|
||||
|
|
@ -16,8 +17,8 @@ type Imports = [(String, ImportMethod)]
|
|||
data ImportMethod = As String | Importing [String] | Hiding [String]
|
||||
deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
name :: Module -> String
|
||||
name :: Module a b -> String
|
||||
name (Module names _ _ _) = intercalate "." names
|
||||
|
||||
path :: Module -> FilePath
|
||||
path :: Module a b -> FilePath
|
||||
path (Module names _ _ _) = joinPath names
|
||||
|
|
@ -5,7 +5,7 @@ import Control.Arrow (first)
|
|||
import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
|
||||
import Control.Monad.State (evalState, State, get, put)
|
||||
import Data.Char (isLower,isDigit)
|
||||
import Guid
|
||||
import Unique
|
||||
import SourceSyntax.Location
|
||||
import SourceSyntax.Pattern
|
||||
import SourceSyntax.Expression
|
||||
|
|
@ -16,17 +16,17 @@ derename var
|
|||
| isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
|
||||
| otherwise = var
|
||||
|
||||
renameModule :: Module -> Module
|
||||
renameModule :: Module t v -> Module t v
|
||||
renameModule modul = run (rename deprime modul)
|
||||
|
||||
class Rename a where
|
||||
rename :: (String -> String) -> a -> GuidCounter a
|
||||
rename :: (String -> String) -> a -> Unique a
|
||||
|
||||
instance Rename Module where
|
||||
instance Rename (Module t v) where
|
||||
rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts
|
||||
return (Module name ex im stmts')
|
||||
|
||||
instance Rename Def where
|
||||
instance Rename (Def t v) where
|
||||
rename env (OpDef op a1 a2 e) =
|
||||
do env' <- extends env [a1,a2]
|
||||
OpDef op (env' a1) (env' a2) `liftM` rename env' e
|
||||
|
|
@ -36,7 +36,7 @@ instance Rename Def where
|
|||
rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)
|
||||
|
||||
|
||||
instance Rename Declaration where
|
||||
instance Rename (Declaration t v) where
|
||||
rename env stmt =
|
||||
case stmt of
|
||||
Definition def -> Definition `liftM` rename env def
|
||||
|
|
@ -60,7 +60,7 @@ renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
|
|||
instance Rename a => Rename (Located a) where
|
||||
rename env (L t s e) = L t s `liftM` rename env e
|
||||
|
||||
instance Rename Expr where
|
||||
instance Rename (Expr t v) where
|
||||
rename env expr =
|
||||
let rnm = rename env in
|
||||
case expr of
|
||||
|
|
@ -115,16 +115,16 @@ instance Rename Expr where
|
|||
|
||||
deprime = map (\c -> if c == '\'' then '$' else c)
|
||||
|
||||
extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
|
||||
extend :: (String -> String) -> String -> Unique (String, String -> String)
|
||||
extend env x = do
|
||||
n <- guid
|
||||
let rx = deprime x ++ "_" ++ show n
|
||||
return (rx, \y -> if y == x then rx else env y)
|
||||
|
||||
extends :: (String -> String) -> [String] -> GuidCounter (String -> String)
|
||||
extends :: (String -> String) -> [String] -> Unique (String -> String)
|
||||
extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
|
||||
|
||||
patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)
|
||||
patternExtend :: Pattern -> (String -> String) -> Unique (Pattern, String -> String)
|
||||
patternExtend pattern env =
|
||||
case pattern of
|
||||
PAnything -> return (PAnything, env)
|
||||
|
|
@ -141,8 +141,8 @@ patternExtend pattern env =
|
|||
return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)
|
||||
|
||||
patternRename :: (String -> String)
|
||||
-> (Pattern, LExpr)
|
||||
-> GuidCounter (Pattern, LExpr)
|
||||
-> (Pattern, LExpr t v)
|
||||
-> Unique (Pattern, LExpr t v)
|
||||
patternRename env (p,e) = do
|
||||
(rp,env') <- patternExtend p env
|
||||
re <- rename env' e
|
||||
|
|
|
|||
19
compiler/Unique.hs
Normal file
19
compiler/Unique.hs
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module Unique (guid, set, run, runAt, Unique) where
|
||||
|
||||
import Control.Monad.State (evalState, State, get, put)
|
||||
|
||||
-- Wrapper around State monad.
|
||||
newtype Unique a = U { runU :: State Int a }
|
||||
deriving (Monad)
|
||||
|
||||
-- Get the next GUID, incrementing the counter.
|
||||
guid :: Unique Int
|
||||
guid = U $ do n <- get
|
||||
put (n + 1)
|
||||
return n
|
||||
|
||||
set n = U (put n)
|
||||
|
||||
run = runAt 0
|
||||
runAt n x = evalState (runU x) n
|
||||
Loading…
Reference in a new issue