b26edcc · elk · git.iko.soy

compiler/Generate/Cases.hs+6−7

compare with master

unifiedsplit

@@ -35,8 +35,8 @@ matchSubst :: [(String,String)] -> Match t v -> Match t v

35matchSubst _ Break = Break

36matchSubst _ Fail = Fail

37matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

38−matchSubst pairs (Other (L t s e)) =

38+matchSubst pairs (Other (L s e)) =

39− Other . L t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

39+ Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

40matchSubst pairs (Match n cs m) =

41 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

42 where varSubst v = fromMaybe v (lookup v pairs)

@@ -63,24 +63,23 @@ match vs@(v:_) cs def

63 where

64 cs' = map (dealias v) cs

65

66−dealias v c@(p:ps, L t s e) =

66+dealias v c@(p:ps, L s e) =

67 case p of

68− PAlias x pattern -> (pattern:ps, L t s $ subst x (Var v) e)

68+ PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)

69 _ -> c

70

71matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v

72 -> Unique (Match t v)

73matchVar (v:vs) cs def = match vs (map subVar cs) def

74 where

75− subVar (p:ps, ce@(L t s e)) = (ps, L t s $ subOnePattern p e)

75+ subVar (p:ps, ce@(L s e)) = (ps, L s $ subOnePattern p e)

76 where

77− loc = L t s

78 subOnePattern pattern e =

77 subOnePattern pattern e =

79 case pattern of

78 case pattern of

80 PVar x -> subst x (Var v) e

79 PVar x -> subst x (Var v) e

81 PAnything -> e

80 PAnything -> e

82 PRecord fs ->

81 PRecord fs ->

83− foldr (\x -> subst x (Access (loc (Var v)) x)) e fs

82+ foldr (\x -> subst x (Access (L s (Var v)) x)) e fs

84

83

85matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v

84matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v

86 -> Unique (Match t v)

85 -> Unique (Match t v)

compiler/Generate/JavaScript.hs+7−7

@@ -147,7 +147,7 @@ instance ToJS a => ToJS [a] where

147 toJS xs = concat `liftM` mapM toJS xs

148

149toJS' :: LExpr t v -> Unique String

150−toJS' (L txt span expr) =

150+toJS' (L span expr) =

151 case expr of

152 MultiIf ps -> multiIfToJS span ps

153 Case e cases -> caseToJS span e cases

@@ -211,7 +211,7 @@ instance ToJS (Expr t v) where

211

212 (patterns, innerBody) = collect [p] e

213

214− collect patterns lexpr@(L a b expr) =

214+ collect patterns lexpr@(L _ expr) =

215 case expr of

216 Lambda p e -> collect (p:patterns) e

217 _ -> (patterns, lexpr)

@@ -245,7 +245,7 @@ jsApp e1 e2 =

245 (func, args) = go [e2] e1

246 go args e =

247 case e of

248− (L _ _ (App e1 e2)) -> go (e2 : args) e1

248+ (L _ (App e1 e2)) -> go (e2 : args) e1

249 _ -> (e, args)

250

251formatMarkdown = concatMap f

@@ -256,7 +256,7 @@ formatMarkdown = concatMap f

256

257multiIfToJS span ps =

258 case last ps of

259− (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)

259+ (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)

260 _ -> format ("_E.If" ++ parens (quoted (show span))) ps

261 where

262 format base ps =

@@ -273,9 +273,9 @@ caseToJS span e ps = do

273 match <- caseToMatch ps

274 e' <- toJS' e

275 let (match',stmt) = case (match,e) of

276− (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,deprime x)] match, "")

276+ (Match name _ _, L _ (Var x)) -> (matchSubst [(name,deprime x)] match, "")

277− (Match name _ _, _) -> (match, assign name e')

277+ (Match name _ _, _) -> (match, assign name e')

278− _ -> (match, "")

278+ _ -> (match, "")

279 matches <- matchToJS span match'

280 return $ "function(){ " ++ stmt ++ matches ++ " }()"

281

compiler/Generate/Noscript.hs+4−4

@@ -23,7 +23,7 @@ instance Extract (Def t v) where

23 extract _ = []

24

25instance Extract e => Extract (Located e) where

26− extract (L _ _ e) = extract e

26+ extract (L _ e) = extract e

27

28instance Extract (Expr t v) where

29 extract expr =

@@ -34,11 +34,11 @@ instance Extract (Expr t v) where

34 ("++", [s1], [s2]) -> [s1 ++ s2]

35 (_ , ss1 , ss2 ) -> ss1 ++ ss2

36 Lambda v e -> f e

37− App (L _ _ (App (L _ _ (App (L _ _ (Var func)) w)) h)) src

37+ App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src

38 | "image" `isInfixOf` func -> extractImage src

39− App (L _ _ (App (L _ _ (Var func)) src)) txt

39+ App (L _ (App (L _ (Var func)) src)) txt

40 | "link" `isInfixOf` func -> extractLink src txt

41− App (L _ _ (Var func)) e

41+ App (L _ (Var func)) e

42 | "header" `isInfixOf` func -> tag "h1" e

43 | "bold" `isInfixOf` func -> tag "b" e

44 | "italic" `isInfixOf` func -> tag "i" e

compiler/Parse/Expression.hs+3−4

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

36 start <- getPosition

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

38 end <- getPosition

39− let loc e = Location.add ("." ++ lbl) (Location.at start end e)

39+ let loc e = Location.at start end e

40 return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))

41

42negative :: IParser (Expr t v)

@@ -215,9 +215,8 @@ funcDef =

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

216

217makeFunction :: [Pattern] -> LExpr t v -> LExpr t v

218−makeFunction args body@(L a b _) =

218+makeFunction args body@(L s _) =

219− let pos = L a b in

220− foldr (\arg body' -> pos $ Lambda arg body') body args

219+ foldr (\arg body' -> L s $ Lambda arg body') body args

221

220

222assignExpr :: IParser (Def t v)

221assignExpr :: IParser (Def t v)

223assignExpr = withPos $ do

222assignExpr = withPos $ do

compiler/Parse/Helpers.hs+1−1

@@ -140,7 +140,7 @@ addLocation expr = do

140accessible :: IParser (LExpr t v) -> IParser (LExpr t v)

141accessible expr = do

142 start <- getPosition

143− ce@(L s t e) <- expr

143+ ce@(L _ e) <- expr

144 let rest f = do

145 let dot = char '.' >> notFollowedBy (char '.')

146 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")

compiler/SourceSyntax/Expression.hs+5−5

@@ -40,7 +40,7 @@ data Def tipe var

40

41tuple es = Data ("_Tuple" ++ show (length es)) es

42

43−delist (Location.L _ _ (Data "::" [h,t])) = h : delist t

43+delist (Location.L _ (Data "::" [h,t])) = h : delist t

44delist _ = []

45

46saveEnvName = "_save_the_environment!!!"

@@ -77,7 +77,7 @@ instance Pretty (Expr t v) where

77 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

78 Access e x -> prettyParens e <> P.text "." <> P.text x

79 Remove e x -> P.braces (pretty e <+> P.text "-" <+> P.text x)

80− Insert (Location.L _ _ (Remove e y)) x v ->

80+ Insert (Location.L _ (Remove e y)) x v ->

81 P.braces (pretty e <+> P.text "-" <+> P.text y <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)

82 Insert e x v ->

83 P.braces (pretty e <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)

@@ -104,19 +104,19 @@ instance Pretty (Def t v) where

104 Def pattern expr ->

105 pretty pattern <+> P.text "=" <+> pretty expr

106

107−collectApps lexpr@(Location.L _ _ expr) =

107+collectApps lexpr@(Location.L _ expr) =

108 case expr of

109 App a b -> collectApps a ++ [b]

110 _ -> [lexpr]

111

112−collectLambdas lexpr@(Location.L _ _ expr) =

112+collectLambdas lexpr@(Location.L _ expr) =

113 case expr of

114 Lambda pattern body ->

115 let (ps, body') = collectLambdas body

116 in (pretty pattern : ps, body')

117 _ -> ([], lexpr)

118

119−prettyParens (Location.L _ _ expr) = parensIf needed (pretty expr)

119+prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

120 where

121 needed =

122 case expr of

compiler/SourceSyntax/Location.hs+8−13

@@ -1,16 +1,16 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2module SourceSyntax.Location where

3

4−import Text.Parsec.Pos

4+import qualified Text.Parsec.Pos as Parsec

5import Data.Data

6

7−data SrcPos = Pos Int Int

7+data SrcPos = Pos { line :: Int, column :: Int }

8 deriving (Eq, Ord, Data, Typeable)

9

10data SrcSpan = Span SrcPos SrcPos | NoSpan

11 deriving (Eq, Ord, Data, Typeable)

12

13−data Located e = L (Maybe String) SrcSpan e

13+data Located e = L SrcSpan e

14 deriving (Eq, Ord, Data, Typeable)

15

16

@@ -24,21 +24,16 @@ instance Show SrcSpan where

24 NoSpan -> ""

25

26instance Show e => Show (Located e) where

27− show (L _ _ e) = show e

27+ show (L _ e) = show e

28

29

30+none = L NoSpan

30

31

31−none = L Nothing NoSpan

32+at start end = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))

33+ (Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end )))

32

34

33−at start end = L Nothing

34− (Span (Pos (sourceLine start) (sourceColumn start))

35− (Pos (sourceLine end ) (sourceColumn end )))

36−

37−merge (L _ s1 _) (L _ s2 _) = L Nothing span

35+merge (L s1 _) (L s2 _) = L span

38 where span = case (s1,s2) of

36 where span = case (s1,s2) of

39 (Span start _, Span _ end) -> Span start end

37 (Span start _, Span _ end) -> Span start end

40 (_, NoSpan) -> s1

38 (_, NoSpan) -> s1

41 (NoSpan, _) -> s2

39 (NoSpan, _) -> s2

42−

43−add x (L Nothing span e) = L (Just (show x)) span e

44−add x (L txt span e) = L txt span e

compiler/SourceSyntax/PrettyPrint.hs+1−1

@@ -9,7 +9,7 @@ class Pretty a where

9 pretty :: a -> Doc

10

11instance Pretty a => Pretty (Located a) where

12− pretty (L _ _ e) = pretty e

12+ pretty (L _ e) = pretty e

13

14instance Pretty () where

15 pretty () = empty

compiler/Transform/Canonicalize.hs+2−2

@@ -101,12 +101,12 @@ replace env v =

101 "\nClose matches include: " ++ List.intercalate ", " matches

102

103rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)

104−rename env lexpr@(L t s expr) =

104+rename env lexpr@(L s expr) =

105 let rnm = rename env

106 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

107 format = Either.either throw return

108 in

109− L t s `liftM`

109+ L s `liftM`

110 case expr of

111 Literal lit -> return expr

112

compiler/Transform/SortDefinitions.hs+5−5

@@ -40,15 +40,15 @@ bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

40sortDefs :: LExpr t v -> LExpr t v

41sortDefs expr = evalState (reorder expr) Set.empty

42

43−flattenLets defs lexpr@(L _ _ expr) =

43+flattenLets defs lexpr@(L _ expr) =

44 case expr of

45 Let ds body -> flattenLets (defs ++ ds) body

46 _ -> (defs, lexpr)

47

48

49reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)

50−reorder lexpr@(L a b expr) =

50+reorder lexpr@(L s expr) =

51− L a b `liftM`

51+ L s `liftM`

52 case expr of

53 -- Be careful adding and restricting freeVars

54 Var x -> free x >> return expr

@@ -119,13 +119,13 @@ reorder lexpr@(L a b expr) =

119 bound (boundVars pattern)

120 mapM free (ctors pattern)

121

122− let addDefs ds bod = L a b (Let (concatMap toDefs ds) bod)

122+ let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)

123 where

124 toDefs (pattern, expr, Nothing) = [ Def pattern expr ]

125 toDefs (PVar name, expr, Just tipe) =

126 [ TypeAnnotation name tipe, Def (PVar name) expr ]

127

128− L _ _ let' = foldr addDefs body' defss

128+ L _ let' = foldr addDefs body' defss

129

130 return let'

131

compiler/Transform/Substitute.hs+1−1

@@ -7,7 +7,7 @@ import Control.Arrow (second, (***))

7

8subst :: String -> Expr t v -> Expr t v -> Expr t v

9subst old new expr =

10− let f (L t s e) = L t s (subst old new e) in

10+ let f (L s e) = L s (subst old new e) in

11 case expr of

12 Range e1 e2 -> Range (f e1) (f e2)

13 ExplicitList es -> ExplicitList (map f es)

compiler/Type/Constrain/Declaration.hs+2−2

@@ -50,9 +50,9 @@ toDefs decl =

50 -- but they do not require any basic constraints.

51 TypeAlias _ _ _ -> []

52

53− ImportEvent _ expr@(Src.L a b _) name tipe ->

53+ ImportEvent _ expr@(Src.L s _) name tipe ->

54 [ Src.TypeAnnotation name tipe

55− , Src.Def (Src.PVar name) (Src.L a b $ Src.App (Src.L a b $ Src.Var "constant") expr) ]

55+ , Src.Def (Src.PVar name) (Src.L s $ Src.App (Src.L s $ Src.Var "constant") expr) ]

56

57 ExportEvent _ name tipe ->

58 [ Src.TypeAnnotation name tipe ]

compiler/Type/Constrain/Expression.hs+2−2

@@ -22,7 +22,7 @@ import qualified Transform.SortDefinitions as SD

22

23

24constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint

25−constrain env (L _ _ expr) tipe =

25+constrain env (L _ expr) tipe =

26 let list t = Env.get env Env.types "_List" <| t in

27 case expr of

28 Literal lit -> Literal.constrain env lit tipe

@@ -132,7 +132,7 @@ constrain env (L _ _ expr) tipe =

132

133 Let defs body ->

134 do c <- case body of

135− L _ _ (Var name) | name == saveEnvName -> return CSaveEnv

135+ L _ (Var name) | name == saveEnvName -> return CSaveEnv

136 _ -> constrain env body tipe

137 (schemes, rqs, fqs, header, c2, c1) <-

138 Monad.foldM (constrainDef env)