6ba2d70 · elk · git.iko.soy

compiler/Compiler.hs+1−2

compare with master

unifiedsplit

@@ -150,8 +150,7 @@ buildFile flags moduleNum numModules interfaces filePath =

150 let interface = Canonical.interface name $ ModuleInterface {

151 iTypes = types metaModule,

152 iAdts = datatypes metaModule,

153− iAliases = aliases metaModule,

153+ iAliases = aliases metaModule

154− iFixities = fixities metaModule

155 }

154 }

156 createDirectoryIfMissing True . dropFileName $ elmi flags filePath

155 createDirectoryIfMissing True . dropFileName $ elmi flags filePath

157 handle <- openBinaryFile (elmi flags filePath) WriteMode

156 handle <- openBinaryFile (elmi flags filePath) WriteMode

compiler/Initialize.hs+1−4

@@ -23,10 +23,7 @@ import qualified Transform.Canonicalize as Canonical

23buildFromSource :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())

24buildFromSource noPrelude interfaces source =

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−

29− modul@(Module _ _ _ decls') <- add `fmap` Parse.program infixes source

26+ modul@(Module _ _ _ decls') <- add `fmap` Parse.program source

30

27

31 -- check for structural errors

28 -- check for structural errors

32 Module names exs ims decls <-

29 Module names exs ims decls <-

compiler/Parse/Binop.hs+12−8

@@ -1,4 +1,4 @@

1−module Parse.Binop (binops, infixStmt, OpTable, preludeTable) where

1+module Parse.Binop (binops, infixStmt, OpTable) where

2

3import Control.Applicative ((<$>))

4import Control.Monad.Error

@@ -11,8 +11,10 @@ import SourceSyntax.Declaration (Assoc(..))

11import Text.Parsec

12import Parse.Helpers

13

14+type OpTable = [(Int, Assoc, String)]

15+

14preludeTable :: OpTable

16preludeTable :: OpTable

15−preludeTable = Map.fromList $ map (\(lvl,assoc,op) -> (op, (lvl,assoc)))

17+preludeTable =

16 [ (9, R, ".")

18 [ (9, R, ".")

17 , (8, R, "^")

19 , (8, R, "^")

18 , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")

20 , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")

@@ -27,22 +29,24 @@ preludeTable = Map.fromList $ map (\(lvl,assoc,op) -> (op, (lvl,assoc)))

27 ]

29 ]

28

30

29opLevel :: OpTable -> String -> Int

31opLevel :: OpTable -> String -> Int

30−opLevel table op = fst $ Map.findWithDefault (9,R) op table

32+opLevel table op = Map.findWithDefault 9 op dict

33+ where dict = Map.fromList (map (\(lvl,_,op) -> (op,lvl)) table)

31

34

32opAssoc :: OpTable -> String -> Assoc

35opAssoc :: OpTable -> String -> Assoc

33−opAssoc table op = snd $ Map.findWithDefault (9,R) op table

36+opAssoc table op = Map.findWithDefault R op dict

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

34

38

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

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

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

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

37

41

42+binops :: OpTable

38−binops :: IParser (LExpr t v)

43+ -> IParser (LExpr t v)

39 -> IParser (LExpr t v)

44 -> IParser (LExpr t v)

40 -> IParser String

45 -> IParser String

41 -> IParser (LExpr t v)

46 -> IParser (LExpr t v)

42−binops term last anyOp =

47+binops table term last anyOp =

43 do e <- term

48 do e <- term

44− table <- getState

45− split table 0 e =<< nextOps

49+ split (table ++ preludeTable) 0 e =<< nextOps

46 where

50 where

47 nextOps = choice [ commitIf (whitespace >> anyOp) $ do

51 nextOps = choice [ commitIf (whitespace >> anyOp) $ do

48 whitespace ; op <- anyOp ; whitespace

52 whitespace ; op <- anyOp ; whitespace

compiler/Parse/Expression.hs+1−1

@@ -144,7 +144,7 @@ appExpr = do

144-------- Normal Expressions --------

145

146binaryExpr :: IParser (LExpr t v)

147−binaryExpr = binops appExpr lastExpr anyOp

147+binaryExpr = binops [] appExpr lastExpr anyOp

148 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

149 <|> lambdaExpr

150

compiler/Parse/Helpers.hs+4−11

@@ -5,11 +5,9 @@ import Control.Monad

5import Control.Monad.State

6import Data.Char (isUpper)

7import qualified Data.Set as Set

8−import qualified Data.Map as Map

9import SourceSyntax.Helpers as Help

8import SourceSyntax.Helpers as Help

10import SourceSyntax.Location as Location

9import SourceSyntax.Location as Location

11import SourceSyntax.Expression

10import SourceSyntax.Expression

12−import SourceSyntax.Declaration (Assoc)

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

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

14import Text.Parsec.Indent

12import Text.Parsec.Indent

15

13

@@ -37,16 +35,11 @@ jsReserveds = Set.fromList

37

35

38expecting = flip (<?>)

36expecting = flip (<?>)

39

37

40−type OpTable = Map.Map String (Int, Assoc)

38+type IParser a = ParsecT String () (State SourcePos) a

41

39

42−type IParser a = ParsecT String OpTable (State SourcePos) a

43−

44−iParse :: IParser a -> String -> Either ParseError a

45−iParse = iParseWithTable "" Map.empty

46−

47−iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseError a

40+iParse :: IParser a -> SourceName -> String -> Either ParseError a

48−iParseWithTable sourceName table aParser input =

41+iParse aParser source_name input =

49− runIndent sourceName $ runParserT aParser table sourceName input

42+ runIndent source_name $ runParserT aParser () source_name input

50

43

51backslashed :: IParser Char

44backslashed :: IParser Char

52backslashed = do { char '\\'; c <- anyChar

45backslashed = do { char '\\'; c <- anyChar

compiler/Parse/Module.hs+1−1

@@ -13,7 +13,7 @@ varList = parens $ commaSep1 (var <|> parens symOp)

13

14getModuleName :: String -> Maybe String

15getModuleName source =

16− case iParse getModuleName source of

16+ case iParse getModuleName "" source of

17 Right name -> Just name

18 Left _ -> Nothing

19 where

compiler/Parse/Parse.hs+4−40

@@ -4,13 +4,12 @@ import Control.Applicative ((<$>), (<*>))

4import Control.Monad

5import Data.Char (isSymbol, isDigit)

6import Data.List (foldl',intercalate)

7−import qualified Data.Map as Map

8import Text.Parsec hiding (newline,spaces)

7import Text.Parsec hiding (newline,spaces)

9import qualified Text.PrettyPrint as P

8import qualified Text.PrettyPrint as P

10

9

11import qualified SourceSyntax.Module as S

10import qualified SourceSyntax.Module as S

12import Parse.Helpers

11import Parse.Helpers

13−import Parse.Binop (infixStmt, OpTable, preludeTable)

12+import Parse.Binop (infixStmt, OpTable)

14import Parse.Expression

13import Parse.Expression

15import Parse.Type

14import Parse.Type

16import Parse.Module

15import Parse.Module

@@ -23,8 +22,8 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

23decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

22decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

24 (d:) <$> many freshDef

23 (d:) <$> many freshDef

25

24

26−program :: OpTable -> String -> Either [P.Doc] (S.Module t v)

25+program :: String -> Either [P.Doc] (S.Module t v)

27−program table = setupParserWithTable table $ do

26+program = setupParser $ do

28 optional freshLine

27 optional freshLine

29 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

28 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

30 is <- (do try (lookAhead $ reserved "import")

29 is <- (do try (lookAhead $ reserved "import")

@@ -41,43 +40,8 @@ dependencies =

41 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

40 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

42 <*> option [] (map fst <$> imports `followedBy` freshLine)

41 <*> option [] (map fst <$> imports `followedBy` freshLine)

43

42

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 preludeTable --(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−

79setupParser :: IParser a -> String -> Either [P.Doc] a

43setupParser :: IParser a -> String -> Either [P.Doc] a

80setupParser p source =

44setupParser p source =

81− case iParse p source of

45+ case iParse p "" source of

82 Right result -> Right result

46 Right result -> Right result

83 Left err -> Left [ P.text $ "Parse error at " ++ show err ]

47 Left err -> Left [ P.text $ "Parse error at " ++ show err ]

compiler/SourceSyntax/Module.hs+5−17

@@ -41,23 +41,11 @@ type Interfaces = Map.Map String ModuleInterface

41type ADT = (String, [String], [(String,[Type])])

42

43data ModuleInterface = ModuleInterface {

44− iTypes :: Map.Map String Type,

44+ iTypes :: Map.Map String Type,

45− iAdts :: [ADT],

45+ iAdts :: [ADT],

46− iAliases :: [(String, [String], Type)],

46+ iAliases :: [(String, [String], Type)]

47− iFixities :: [(Assoc, Int, String)]

48} deriving Show

47} deriving Show

49

48

50instance Binary ModuleInterface where

49instance Binary ModuleInterface where

51− get = ModuleInterface <$> get <*> get <*> get <*> get

52− put modul = do

53− put (iTypes modul)

54− put (iAdts modul)

55− put (iAliases modul)

50+ put modul = put (iTypes modul) >> put (iAdts modul) >> put (iAliases modul)

56− put (iFixities modul)

51+ get = ModuleInterface <$> get <*> get <*> get

57−

58−

59−instance Binary Assoc where

60− get = do n <- getWord8

61− return $ case n of { 0 -> L ; 1 -> N ; 2 -> R }

62−

63− put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

compiler/Transform/Canonicalize.hs+4−5

@@ -18,11 +18,10 @@ import Text.PrettyPrint as P

18

19interface :: String -> ModuleInterface -> ModuleInterface

20interface moduleName iface =

21− ModuleInterface

21+ ModuleInterface {

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 = iFixities iface -- cannot have canonicalized operators while parsing

26 }

25 }

27 where

26 where

28 both f g (a,b,c) = (f a, b, g c)

27 both f g (a,b,c) = (f a, b, g c)