b2a7bd1 · elk · git.iko.soy

elm/src/Ast.hs+1−1

compare with master

unifiedsplit

@@ -52,7 +52,7 @@ data Def = FnDef String [String] CExpr

52

53data Statement = Definition Def

54 | Datatype String [X] [(String,[Type])]

55− | TypeAlias String Type

55+ | TypeAlias String [X] Type

56 | TypeAnnotation String Type

57 | ImportEvent String CExpr String Type

58 | ExportEvent String String Type

elm/src/Gen/CompileToJS.hs+3−3

@@ -99,7 +99,7 @@ getExports names stmts = ret . braces $ intercalate ",\n" (op : map fnPair fns)

99 Datatype _ _ tcs -> map (Left . fst) tcs

100 ImportEvent _ _ x _ -> [ Left x ]

101 ExportEvent _ _ _ -> []

102− TypeAlias _ _ -> []

102+ TypeAlias _ _ _ -> []

103 TypeAnnotation _ _ -> []

104

105

@@ -138,7 +138,7 @@ stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))

138 if derename f == "main" then 5 else 4

139 Definition _ -> 3

140 ExportEvent _ _ _ -> 6

141− TypeAlias _ _ -> 0

141+ TypeAlias _ _ _ -> 0

142 TypeAnnotation _ _ -> 0

143

144class ToJS a where

@@ -172,7 +172,7 @@ instance ToJS Statement where

172 , "e.value = v;"

173 , "document.dispatchEvent(e); return v; })(", elm, ");" ]

174 toJS (TypeAnnotation _ _) = return ""

175− toJS (TypeAlias _ _) = return ""

175+ toJS (TypeAlias _ _ _) = return ""

176

177toJS' :: CExpr -> GuidCounter String

178toJS' (C txt span expr) =

elm/src/Initialize.hs+5−2

@@ -10,13 +10,16 @@ import Rename

10import Types.Types ((-:))

11import Types.Hints (hints)

12import Types.Unify

13+import Types.Substitutions (dealias)

13import Optimize

14import Optimize

14

15

16

16initialize str =

17initialize str =

17− do modul@(Module name ex im stmts) <- parseProgram str

18+ do Module name ex im stmts <- parseProgram str

19+ let stmts' = dealias stmts

20+ modul = Module name ex im stmts'

18 (escapees, subs) <- unify hints modul

21 (escapees, subs) <- unify hints modul

19− let modul' = optimize . renameModule $ Module name ex im' stmts

22+ let modul' = optimize . renameModule $ Module name ex im' stmts'

20 where im' | any ((=="Prelude") . fst) im = im

23 where im' | any ((=="Prelude") . fst) im = im

21 | otherwise = ("Prelude", Hiding []) : im

24 | otherwise = ("Prelude", Hiding []) : im

22 subs `seq` return (escapees, modul')

25 subs `seq` return (escapees, modul')

elm/src/Parse/Types.hs+10−3

@@ -57,8 +57,9 @@ typeExpr :: IParser ParseType

57typeExpr = do

58 t1 <- typeVar <|> typeApp <|> typeUnambiguous

59 whitespace ; arr <- optionMaybe arrow ; whitespace

60+ case arr of

60− case arr of Just _ -> LambdaPT t1 <$> typeExpr

61+ Just _ -> LambdaPT t1 <$> typeExpr

61− Nothing -> return t1

62+ Nothing -> return t1

62

63

63typeConstructor :: IParser (String, [ParseType])

64typeConstructor :: IParser (String, [ParseType])

64typeConstructor = (,) <$> (capVar <?> "another type constructor")

65typeConstructor = (,) <$> (capVar <?> "another type constructor")

@@ -67,9 +68,15 @@ typeConstructor = (,) <$> (capVar <?> "another type constructor")

67typeAlias :: IParser Statement

68typeAlias :: IParser Statement

68typeAlias = do

69typeAlias = do

69 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

70 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

71+ forcedWS

70 alias <- capVar

72 alias <- capVar

73+ args <- spacePrefix lowVar

71 whitespace ; string "=" ; whitespace

74 whitespace ; string "=" ; whitespace

75+ let n = length args

72− TypeAlias alias <$> toType <$> typeExpr

76+ tipe <- typeExpr

77+ case toTypeWith alias (zip args [1..n]) tipe of

78+ Right t -> return (TypeAlias alias [1..n] t)

79+ Left msg -> fail msg

73

80

74typeAnnotation :: IParser Statement

81typeAnnotation :: IParser Statement

75typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)

82typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)

elm/src/Rename.hs+2−2

@@ -37,7 +37,7 @@ instance Rename Statement where

37 Definition def -> Definition `liftM` rename env def

38 Datatype name args tcs ->

39 return $ Datatype name args $ map (first env) tcs

40− TypeAlias n t -> return (TypeAlias n t)

40+ TypeAlias n xs t -> return (TypeAlias n xs t)

41 TypeAnnotation n t -> return (TypeAnnotation (env n) t)

42 ImportEvent js base elm tipe ->

43 do base' <- rename env base

@@ -144,4 +144,4 @@ renameLet env defs e = do env' <- extends env $ concatMap getNames defs

144 defs' <- mapM (rename env') defs

145 Let defs' `liftM` rename env' e

146 where getNames (FnDef n _ _) = [n]

147− getNames (OpDef _ _ _ _) = []

147+ getNames (OpDef _ _ _ _) = []

elm/src/Types/Constrain.hs+1−2

@@ -305,5 +305,4 @@ stmtGen stmt =

305 do schm <- generalize [] (Forall [] [] tipe)

306 return (Map.empty, Set.empty, Map.singleton name schm)

307

308− _ -> return (Map.empty, Set.empty, Map.empty)

308+ TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)

309−

elm/src/Types/Substitutions.hs+33−1

@@ -4,10 +4,13 @@ module Types.Substitutions (subst,

4 freeVars,

5 concretize,

6 rescheme,

7− generalize) where

7+ generalize,

8+ dealias) where

8

9

10+import Ast

9import Context

11import Context

10import Control.DeepSeq (NFData (..), deepseq)

12import Control.DeepSeq (NFData (..), deepseq)

13+import Control.Arrow (second)

11import Control.Monad (liftM)

14import Control.Monad (liftM)

12import Data.List (foldl')

15import Data.List (foldl')

13import qualified Data.Set as Set

16import qualified Data.Set as Set

@@ -87,3 +90,32 @@ generalize :: [X] -> Scheme -> GuidCounter Scheme

87generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

90generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

88 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs

91 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs

89 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)

92 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)

93+

94+dealias :: [Statement] -> [Statement]

95+dealias stmts = map dealiasS stmts

96+ where

97+ getAliases :: [Statement] -> Map.Map String ([X],Type)

98+ getAliases stmts = Map.fromList (concatMap getAlias stmts)

99+ where getAlias stmt = case stmt of

100+ TypeAlias alias xs t -> [(alias, (xs,t))]

101+ _ -> []

102+

103+ dealiasT :: Type -> Type

104+ dealiasT t =

105+ case t of

106+ ADT name ts -> case Map.lookup name (getAliases stmts) of

107+ Just (xs,t) -> dealiasT (subst (zip xs ts) t)

108+ Nothing -> ADT name (map dealiasT ts)

109+ LambdaT t u -> LambdaT (dealiasT t) (dealiasT u)

110+ RecordT r t -> RecordT (Map.map (map dealiasT) r) (dealiasT t)

111+ _ -> t

112+

113+ dealiasS :: Statement -> Statement

114+ dealiasS s =

115+ case s of

116+ Datatype n xs tcs -> Datatype n xs (map (second (map dealiasT)) tcs)

117+ ExportEvent js elm tipe -> ExportEvent js elm (dealiasT tipe)

118+ ImportEvent js e elm tipe -> ImportEvent js e elm (dealiasT tipe)

119+ TypeAnnotation name tipe -> TypeAnnotation name (dealiasT tipe)

120+ Definition _ -> s

121+ TypeAlias _ _ _ -> s