f5bdb2c · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Minor code changes to help allow custom infix precedence and associativity.

f5bdb2cevancz13 years ago

compiler/Initialize.hs+2−2

compare with master

unifiedsplit

@@ -8,7 +8,7 @@ import qualified Data.Map as Map

8import Ast

9import Data.Either (lefts,rights)

10import Data.List (intercalate,partition)

11−import Parse.Parser (parseProgram, preParse)

11+import Parse.Parser (parseProgram, parseDependencies)

12import Rename

13import qualified Libraries as Libs

14import Types.Types ((-:))

@@ -60,7 +60,7 @@ sortDeps deps = go [] (nub deps)

60readDeps :: [FilePath] -> FilePath -> IO [Deps]

61readDeps seen root = do

62 txt <- readFile root

63− case preParse txt of

63+ case parseDependencies txt of

64 Left err ->

65 let msg = "Error resolving dependencies in " ++ root ++ ":\n" in

66 putStrLn (msg ++ err) >> exitFailure

compiler/Parse/Binops.hs+66−53

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

1−module Parse.Binops (binops) where

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

3import Ast

4import Control.Monad (liftM,guard)

@@ -16,54 +16,57 @@ data Assoc = L | N | R deriving (Eq,Show)

17type OpTable = [(Int, Assoc, String)]

19−table :: OpTable

19+preludeTable :: OpTable

20+preludeTable =

20−table = [ (9, R, ".")

21+ [ (9, R, ".")

21− , (8, R, "^")

22+ , (8, R, "^")

22− , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")

23+ , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")

23− , (6, L, "+"), (6, L, "-")

24+ , (6, L, "+"), (6, L, "-")

24− , (5, R, "::"), (5, R, "++")

25+ , (5, R, "::"), (5, R, "++")

25− , (4, N, "<="), (4, N, ">="), (4, N, "<")

26+ , (4, N, "<="), (4, N, ">="), (4, N, "<")

26− , (4, N, "=="), (4, N, "/="), (4, N, ">")

27+ , (4, N, "=="), (4, N, "/="), (4, N, ">")

27− , (4, L, "~"), (4, L, "<~")

28+ , (4, L, "~"), (4, L, "<~")

28− , (3, R, "&&")

29+ , (3, R, "&&")

29− , (2, R, "||")

30+ , (2, R, "||")

30− , (0, R, "$")

31− , (0, R, "<|"), (0, L, "|>")

31+ , (0, R, "<|"), (0, L, "|>")

32− ]

32+ ]

33−

33+

34+opLevel :: OpTable -> String -> Int

34−opLevel op = Map.findWithDefault 9 op dict

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

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

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

38+opAssoc :: OpTable -> String -> Assoc

37−opAssoc op = Map.findWithDefault R op dict

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

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

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

42+hasLevel :: OpTable -> Int -> (String,CExpr) -> Bool

40−hasLevel n (op,e) = opLevel op == n

43+hasLevel table n (op,_) = opLevel table op == n

41−

44+

42−sortOps :: OpTable -> OpTable

43−sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)

44−

45−binops :: IParser CExpr -> IParser String -> IParser CExpr

45+binops :: OpTable -> IParser CExpr -> IParser String -> IParser CExpr

46−binops term anyOp = do

46+binops table term anyOp =

47− e <- term

47+ do e <- term

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

49+ where

48− split 0 e =<< many (commitIf (whitespace >> anyOp) $ do

50+ nextOp = commitIf (whitespace >> anyOp) $ do

49− whitespace ; op <- anyOp

51+ whitespace ; op <- anyOp

50− whitespace ; e <- term

52+ whitespace ; e <- term

51− return (op,e))

53+ return (op,e)

52−

54+

53−split :: Int -> CExpr -> [(String, CExpr)] -> IParser CExpr

55+split :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> IParser CExpr

54−split _ e [] = return e

56+split _ _ e [] = return e

55−split n e eops = do

57+split table n e eops = do

56− assoc <- getAssoc n eops

58+ assoc <- getAssoc table n eops

57− es <- sequence (splitLevel n e eops)

59+ es <- sequence (splitLevel table n e eops)

58− let ops = map fst (filter (hasLevel n) eops)

60+ let ops = map fst (filter (hasLevel table n) eops)

59 case assoc of R -> joinR es ops

61 case assoc of R -> joinR es ops

60 _ -> joinL es ops

62 _ -> joinL es ops

62−splitLevel :: Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]

64+splitLevel :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]

63−splitLevel n e eops =

65+splitLevel table n e eops =

64− case break (hasLevel n) eops of

66+ case break (hasLevel table n) eops of

67+ (lops, (op,e'):rops) ->

65− (lops, (op,e'):rops) -> split (n+1) e lops : splitLevel n e' rops

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

66− (lops, []) -> [ split (n+1) e lops ]

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

68joinL :: [CExpr] -> [String] -> IParser CExpr

71joinL :: [CExpr] -> [String] -> IParser CExpr

69joinL [e] [] = return e

72joinL [e] [] = return e

@@ -76,14 +79,24 @@ joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

76 return (epos a e (Binop op a e))

79 return (epos a e (Binop op a e))

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

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

79−getAssoc :: Int -> [(String,CExpr)] -> IParser Assoc

82+getAssoc :: OpTable -> Int -> [(String,CExpr)] -> IParser Assoc

83+getAssoc table n eops

80−getAssoc n eops | all (==L) assocs = return L

84+ | all (==L) assocs = return L

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

85+ | all (==R) assocs = return R

82− | all (==N) assocs = case assocs of [_] -> return N

86+ | all (==N) assocs = case assocs of [_] -> return N

83− _ -> fail msg

87+ _ -> fail msg

84− where levelOps = filter (hasLevel n) eops

88+ where levelOps = filter (hasLevel table n) eops

85− assocs = map (opAssoc . fst) levelOps

89+ assocs = map (opAssoc table . fst) levelOps

86− msg = concat [ "Conflicting precedence for binary operators ("

90+ msg = concat [ "Conflicting precedence for binary operators ("

87− , intercalate ", " (map fst eops), "). "

91+ , intercalate ", " (map fst eops), "). "

88− , "Consider adding parentheses to disambiguate." ]

92+ , "Consider adding parentheses to disambiguate." ]

89−

93+

94+infixStmt :: IParser (Int, Assoc, String)

95+infixStmt =

96+ let infx str assoc = try (reserved ("infix" ++ str) >> return assoc) in

97+ do assoc <- choice [ infx "l" L, infx "r" R, infx "" N ]

98+ whitespace

99+ prec <- do n <- digit ; return (read [n] :: Int)

100+ whitespace

101+ op <- anyOp

102+ return (prec, assoc, op)

compiler/Parse/Expr.hs+1−1

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

141-------- Normal Expressions --------

142

143binaryExpr :: IParser CExpr

144−binaryExpr = binops appExpr anyOp

144+binaryExpr = binops [] appExpr anyOp

145

146ifExpr :: IParser Expr

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

compiler/Parse/Parser.hs+12−5

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

1−module Parse.Parser (parseProgram, preParse) where

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

3import Ast

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

@@ -8,6 +8,7 @@ import Data.List (foldl',intercalate)

8import Text.Parsec hiding (newline,spaces)

10import Parse.Library

11+import Parse.Binops (infixStmt, OpTable)

11import Parse.Expr

12import Parse.Expr

12import Parse.Types

13import Parse.Types

13import Parse.Modules

14import Parse.Modules

@@ -35,10 +36,11 @@ program = do

36parseProgram = setupParser program

37parseProgram = setupParser program

38−preParse :: String -> Either String (String, [String])

39+parseDependencies :: String -> Either String (String, [String])

40+parseDependencies =

39−preParse = setupParser $ do

41+ setupParser $ do

40− optional skip

42+ optional skip

41− (,) <$> option "Main" moduleName <*> option [] imprts

43+ (,) <$> option "Main" moduleName <*> option [] imprts

42 where

44 where

43 skip = try (manyTill anyChar (try (string "/**")))

45 skip = try (manyTill anyChar (try (string "/**")))

44 imprts = fmap (map fst) imports `followedBy` freshLine

46 imprts = fmap (map fst) imports `followedBy` freshLine

@@ -46,6 +48,11 @@ preParse = setupParser $ do

46 moduleName = do optional freshLine

48 moduleName = do optional freshLine

47 getName <$> moduleDef `followedBy` freshLine

49 getName <$> moduleDef `followedBy` freshLine

51+parseInfix :: String -> Either String OpTable

52+parseInfix = setupParser . many $ do

53+ manyTill (whitespace <|> (anyChar >> return ())) freshLine

54+ infixStmt

55+

49setupParser p source =

56setupParser p source =

50 case iParse p "" source of

57 case iParse p "" source of

51 Right result -> Right result

58 Right result -> Right result