git.iko.soy/elk
on master help sign in
support cross-module OpTables
d7c89eeEvan Czaplicki
compiler/Initialize.hs+4−1
compare with master
unifiedsplit
@@ -23,7 +23,10 @@ import qualified Transform.Canonicalize as Canonical
23buildFromSource :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())
23buildFromSource :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())
24buildFromSource noPrelude interfaces source =
24buildFromSource noPrelude interfaces source =
25 do let add = if noPrelude then id else Prelude.add
25 do let add = if noPrelude then id else Prelude.add
26+ infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
27+ . concatMap iFixities $ Map.elems interfaces
28+
26− modul@(Module _ _ _ decls') <- add `fmap` Parse.program source
29+ modul@(Module _ _ _ decls') <- add `fmap` Parse.program infixes source
27
30
28 -- check for structural errors
31 -- check for structural errors
29 Module names exs ims decls <-
32 Module names exs ims decls <-
compiler/Parse/Binop.hs+2−2
@@ -1,4 +1,4 @@
1−module Parse.Binop (binops, infixStmt, OpTable) where
1+module Parse.Binop (binops, infixStmt, OpTable, preludeTable) where
2
2
3import Control.Applicative ((<$>))
3import Control.Applicative ((<$>))
4import Control.Monad.Error
4import Control.Monad.Error
@@ -42,7 +42,7 @@ binops :: IParser (LExpr t v)
42binops term last anyOp =
42binops term last anyOp =
43 do e <- term
43 do e <- term
44 table <- getState
44 table <- getState
45− split (Map.union preludeTable table) 0 e =<< nextOps
45+ split table 0 e =<< nextOps
46 where
46 where
47 nextOps = choice [ commitIf (whitespace >> anyOp) $ do
47 nextOps = choice [ commitIf (whitespace >> anyOp) $ do
48 whitespace ; op <- anyOp ; whitespace
48 whitespace ; op <- anyOp ; whitespace
compiler/Parse/Parse.hs+39−3
@@ -4,12 +4,13 @@ import Control.Applicative ((<$>), (<*>))
4import Control.Monad
4import Control.Monad
5import Data.Char (isSymbol, isDigit)
5import Data.Char (isSymbol, isDigit)
6import Data.List (foldl',intercalate)
6import Data.List (foldl',intercalate)
7+import qualified Data.Map as Map
7import Text.Parsec hiding (newline,spaces)
8import Text.Parsec hiding (newline,spaces)
8import qualified Text.PrettyPrint as P
9import qualified Text.PrettyPrint as P
9
10
10import qualified SourceSyntax.Module as S
11import qualified SourceSyntax.Module as S
11import Parse.Helpers
12import Parse.Helpers
12−import Parse.Binop (infixStmt, OpTable)
13+import Parse.Binop (infixStmt, OpTable, preludeTable)
13import Parse.Expression
14import Parse.Expression
14import Parse.Type
15import Parse.Type
15import Parse.Module
16import Parse.Module
@@ -22,8 +23,8 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
22decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
23decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
23 (d:) <$> many freshDef
24 (d:) <$> many freshDef
24
25
25−program :: String -> Either [P.Doc] (S.Module t v)
26+program :: OpTable -> String -> Either [P.Doc] (S.Module t v)
26−program = setupParser $ do
27+program table = setupParserWithTable table $ do
27 optional freshLine
28 optional freshLine
28 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
29 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
29 is <- (do try (lookAhead $ reserved "import")
30 is <- (do try (lookAhead $ reserved "import")
@@ -40,6 +41,41 @@ dependencies =
40 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)
41 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)
41 <*> option [] (map fst <$> imports `followedBy` freshLine)
42 <*> option [] (map fst <$> imports `followedBy` freshLine)
42
43
44+setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
45+setupParserWithTable table p source =
46+ do let initialTable = Map.union preludeTable table
47+ localTable <- setupParser parseFixities source
48+ case Map.intersection initialTable localTable of
49+ overlap | not (Map.null overlap) -> Left [ msg overlap ]
50+ | otherwise ->
51+ flip setupParser source $ do
52+ putState (Map.union initialTable localTable)
53+ p
54+ where
55+ msg overlap =
56+ P.vcat [ P.text "Parse error:"
57+ , P.text $ "Overlapping definitions for infix operators: " ++
58+ intercalate " " (Map.keys overlap)
59+ ]
60+
61+parseFixities = infixes []
62+ where
63+ nil p = const () <$> p
64+ manyTil p end = end <|> (p >> manyTil p end)
65+
66+ eatLine = manyTil (nil multiComment <|> nil anyChar)
67+ (const False <$> simpleNewline <|> const True <$> eof)
68+
69+ infixes stmts = do
70+ next <- Left <$> infixStmt <|> Right <$> eatLine
71+ case next of
72+ Left stmt -> infixes (stmt:stmts)
73+ Right True -> return $ format stmts
74+ Right False -> infixes stmts
75+
76+ format = Map.fromList . map (\(lvl,assoc,op) -> (op, (lvl,assoc)))
77+
78+
43setupParser :: IParser a -> String -> Either [P.Doc] a
79setupParser :: IParser a -> String -> Either [P.Doc] a
44setupParser p source =
80setupParser p source =
45 case iParse p source of
81 case iParse p source of
compiler/Transform/Canonicalize.hs+1−1
@@ -22,7 +22,7 @@ interface moduleName iface =
22 { iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))
22 { iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))
23 , iAdts = map (both prefix renameCtors) (iAdts iface)
23 , iAdts = map (both prefix renameCtors) (iAdts iface)
24 , iAliases = map (both prefix renameType') (iAliases iface)
24 , iAliases = map (both prefix renameType') (iAliases iface)
25− , iFixities = map (both id prefix) (iFixities iface)
25+ , iFixities = iFixities iface -- cannot have canonicalized operators while parsing
26 }
26 }
27 where
27 where
28 both f g (a,b,c) = (f a, b, g c)
28 both f g (a,b,c) = (f a, b, g c)