021a27c · elk · git.iko.soy

elm/src/Ast.hs+2

compare with master

unifiedsplit

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

52

53data Statement = Definition Def

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

55+ | TypeAlias String Type

56+ | TypeAnnotation String Type

55 | ImportEvent String CExpr String Type

57 | ImportEvent String CExpr String Type

56 | ExportEvent String String Type

58 | ExportEvent String String Type

57 deriving (Eq,Show)

59 deriving (Eq,Show)

elm/src/Gen/CompileToJS.hs+6

@@ -99,6 +99,8 @@ 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 _ _ -> []

103+ TypeAnnotation _ _ -> []

102

104

103

105

104jsImport (modul, how) =

106jsImport (modul, how) =

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

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

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

137 Definition _ -> 3

139 Definition _ -> 3

138 ExportEvent _ _ _ -> 6

140 ExportEvent _ _ _ -> 6

141+ TypeAlias _ _ -> 0

142+ TypeAnnotation _ _ -> 0

139

143

140class ToJS a where

144class ToJS a where

141 toJS :: a -> GuidCounter String

145 toJS :: a -> GuidCounter String

@@ -167,6 +171,8 @@ instance ToJS Statement where

167 , "e.initEvent('", js, "', true, true);"

171 , "e.initEvent('", js, "', true, true);"

168 , "e.value = v;"

172 , "e.value = v;"

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

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

174+ toJS (TypeAnnotation _ _) = return ""

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

170

176

171toJS' :: CExpr -> GuidCounter String

177toJS' :: CExpr -> GuidCounter String

172toJS' (C txt span expr) =

178toJS' (C txt span expr) =

elm/src/Parse/Foreign.hs+2−2

@@ -19,7 +19,7 @@ exportEvent = do

19 try (reserved "export" >> whitespace >> reserved "jsevent" >> whitespace)

20 js <- jsVar ; whitespace

21 elm <- lowVar ; whitespace

22− string "::" ; whitespace

22+ hasType ; whitespace

23 tipe <- typeExpr

24 case tipe of

25 ADTPT "Signal" [pt] ->

@@ -32,7 +32,7 @@ importEvent = do

32 base <- term <?> "Base case for imported signal (signals cannot be undefined)"

33 whitespace

34 elm <- lowVar <?> "Name of imported signal"

35− whitespace ; string "::" ; whitespace

35+ whitespace ; hasType ; whitespace

36 tipe <- typeExpr

37 case tipe of

38 ADTPT "Signal" [pt] ->

elm/src/Parse/Library.hs+6−2

@@ -12,8 +12,9 @@ import Text.Parsec hiding (newline,spaces,State)

12import Text.Parsec.Indent

13

14reserveds = [ "if", "then", "else"

15− , "case", "of", "data"

15+ , "case", "of"

16 , "let", "in"

17+ , "data", "type"

17 , "module", "where"

18 , "module", "where"

18 , "import", "as", "hiding"

19 , "import", "as", "hiding"

19 , "export", "foreign" ]

20 , "export", "foreign" ]

@@ -61,7 +62,7 @@ isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"

61

62

62symOp :: IParser String

63symOp :: IParser String

63symOp = do op <- many1 (satisfy isOp)

64symOp = do op <- many1 (satisfy isOp)

64− guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594" ])

65+ guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])

65 case op of

66 case op of

66 "." -> notFollowedBy lower >> return op

67 "." -> notFollowedBy lower >> return op

67 "\8728" -> return "."

68 "\8728" -> return "."

@@ -70,6 +71,9 @@ symOp = do op <- many1 (satisfy isOp)

70arrow :: IParser String

71arrow :: IParser String

71arrow = string "->" <|> string "\8594" <?> "arrow (->)"

72arrow = string "->" <|> string "\8594" <?> "arrow (->)"

72

73

74+hasType :: IParser String

75+hasType = string ":" <?> "':' (a type annotation)'"

76+

73

77

74commitIf check p = commit <|> try p

78commitIf check p = commit <|> try p

75 where commit = do (try $ lookAhead check) >> p

79 where commit = do (try $ lookAhead check) >> p

elm/src/Parse/Parser.hs+2−4

@@ -14,10 +14,8 @@ import Parse.Modules

14import Parse.Foreign

15

16

17−statement = (:[]) <$> foreignDef

17+statement = let defs = [ foreignDef, datatype, typeAlias, typeAnnotation ] in

18− <|> (:[]) <$> datatype

19− <|> def

20− <?> "datatype or variable definition"

18+ (:[]) <$> choice defs <|> def <?> "datatype or variable definition"

21

19

22freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

20freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

23 freshLine

21 freshLine

elm/src/Parse/Types.hs+44−14

@@ -34,7 +34,7 @@ typeTuple = do ts <- parens (commaSep typeExpr)

34typeRecord :: IParser ParseType

35typeRecord = fmap RecordPT . brackets . commaSep $ do

36 lbl <- rLabel

37− whitespace >> string "::" >> whitespace

37+ whitespace >> hasType >> whitespace

38 (,) lbl <$> typeExpr

39

40typeUnambiguous :: IParser ParseType

@@ -64,6 +64,18 @@ typeConstructor :: IParser (String, [ParseType])

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

65 <*> spacePrefix (typeSimple <|> typeUnambiguous)

66

67+typeAlias :: IParser Statement

68+typeAlias = do

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

70+ alias <- capVar

71+ whitespace ; string "=" ; whitespace

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

73+

74+typeAnnotation :: IParser Statement

75+typeAnnotation =

76+ let start = do v <- lowVar ; whitespace ; hasType ; whitespace ; return v

77+ in TypeAnnotation <$> try start <*> (toType <$> typeExpr)

78+

67datatype :: IParser Statement

79datatype :: IParser Statement

68datatype = do

80datatype = do

69 reserved "data" <?> "datatype definition (data T = A | B | ...)"

81 reserved "data" <?> "datatype definition (data T = A | B | ...)"

@@ -76,21 +88,39 @@ datatype = do

76

88

77beta = liftM VarT guid

89beta = liftM VarT guid

78

90

91+toType :: ParseType -> Type

92+toType pt =

93+ let frees :: ParseType -> [String]

94+ frees pt = case pt of

95+ LambdaPT a b -> frees a ++ frees b

96+ ADTPT _ ts -> concatMap frees ts

97+ RecordPT fs -> concatMap (frees . snd) fs

98+ VarPT (c:cs) | isLower c -> [c:cs]

99+ | otherwise -> []

100+ in case toTypeWith "" (zip (frees pt) [1..]) pt of

101+ Right t -> t

102+ Left _ -> VarT 0

103+

104+toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type

105+toTypeWith name tvarDict pt =

106+ let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."

107+ toT = toTypeWith name tvarDict

108+ in case pt of

109+ LambdaPT t1 t2 -> (==>) <$> toT t1 <*> toT t2

110+ ADTPT name args -> ADT name <$> mapM toT args

111+ RecordPT fs -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs

112+ return (RecordT (recordT fs') EmptyRecord)

113+ VarPT x@(c:_)

114+ | not (isLower c) -> return $ ADT x []

115+ | otherwise -> VarT <$> case lookup x tvarDict of

116+ Just v -> Right v

117+ Nothing -> Left (msg x)

118+

119+

79toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs

120toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs

80 where n = length args

121 where n = length args

81− tvarDict = zip args [1..n]

122+ toType = toTypeWith name (zip args [1..n])

82− toC (name,pt) = (,) name <$> mapM toT pt

123+ toC (name,pt) = (,) name <$> mapM toType pt

83− toT (LambdaPT t1 t2) = (==>) <$> toT t1 <*> toT t2

84− toT (ADTPT name args) = ADT name <$> mapM toT args

85− toT (VarPT x@(c:_))

86− | isLower c = VarT <$> case lookup x tvarDict of

87− Just v -> Right v

88− Nothing -> Left $ msg x

89− | otherwise = return $ ADT x []

90− toT (RecordPT fs) = do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs

91− return (RecordT (recordT fs') EmptyRecord)

92− msg x = "Type variable '" ++ x ++

93− "' is unbound in type constructor '" ++ name ++ "'."

94

124

95

125

96toForeignType (LambdaPT t1 t2) =

126toForeignType (LambdaPT t1 t2) =

elm/src/Rename.hs+12−8

@@ -32,14 +32,18 @@ instance Rename Def where

32 FnDef (env f) (map env' args) `liftM` rename env' e

33

34instance Rename Statement where

35+ rename env stmt =

36+ case stmt of

35− rename env (Definition def) = Definition `liftM` rename env def

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

36− rename env (Datatype name args tcs) =

38+ Datatype name args tcs ->

37− return $ Datatype name args $ map (first env) tcs

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

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

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

38− rename env (ImportEvent js base elm tipe) =

42+ ImportEvent js base elm tipe ->

39− do base' <- rename env base

43+ do base' <- rename env base

40− return $ ImportEvent js base' (env elm) tipe

44+ return $ ImportEvent js base' (env elm) tipe

41− rename env (ExportEvent js elm tipe) =

45+ ExportEvent js elm tipe ->

42− return $ ExportEvent js (env elm) tipe

46+ return $ ExportEvent js (env elm) tipe

43

47

44renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts

48renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts

45 mapM (rename env') stmts

49 mapM (rename env') stmts

elm/src/Types/Constrain.hs+36−35

@@ -198,7 +198,7 @@ gen (C _ span expr) =

198 Str _ -> primitive string

199 Boolean _ -> primitive bool

200 Markdown _ -> primitive element

201− -- _ -> beta >>= primitive

201+

202

203primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)

204primitive t = return (Map.empty, Set.empty, t)

@@ -258,38 +258,39 @@ defGenHelp name args e = do

258 Forall (map snd argDict) (cs' ++ Set.toList cs) tipe

259 return ( as', Set.empty, (name, scheme) )

260

261−stmtGen (Definition def) = do (as,cs,hint) <- defGen def

262− return ( as, cs, [hint] )

263−

264−stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'

265− return (Map.empty, Set.empty, schemes)

266− where var n = length xs + n

267− ( a, b, c) = ( var 1, var 2, var 3)

268− (va,vb,vc) = (VarT a, VarT b, VarT c)

269− rnm (ADT n []) | n == "Number" = va

270− | n == "Appendable" = vb

271− | n == "Comparable" = vc

272− rnm t = t

273− tcs' = map (second (map rnm)) tcs

274− supers t = map (ctx name NoSpan) $

275− zipWith (:<:) [va,vb,vc] [number,appendable t,comparable]

276− gen' (n,ts) = do t <- beta

277− let s = Forall (xs ++ [a,b,c]) (supers t) $

278− foldr (==>) (ADT name $ map VarT xs) ts

279− (,) n `liftM` generalize [] s

280−

281−stmtGen (ExportEvent js elm tipe) = do

282− x <- guid

283− return ( Map.singleton elm [x]

284− , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe

285− , [] )

286−

287−stmtGen (ImportEvent js e@(C txt span base) elm tipe) = do

288− (as,cs,t) <- gen e

289− return ( as

290− , Set.insert (C txt span (signalOf t :=: tipe)) cs

291− , [ (elm, Forall [] [] tipe) ] )

292

261

262+stmtGen :: Statement -> GuidCounter (TVarMap, ConstraintSet, [(String,Scheme)])

263+stmtGen stmt =

264+ case stmt of

265+ Definition def -> do (as,cs,hint) <- defGen def

266+ return ( as, cs, [hint] )

267+

268+ TypeAlias alias t -> return (Map.empty, Set.empty, [])

269+

270+ TypeAnnotation name t ->

271+ do Forall _ _ t' <- generalize [] (Forall [] [] t)

272+ x <- guid

273+ return (Map.singleton name [x],

274+ Set.singleton (ctx name NoSpan $ VarT x :=: t'),

275+ [])

276+

293−getDatatypeInfo (Datatype name args tcs) =

277+ Datatype name xs tcs ->

294− Just (name, args, tcs)

278+ let toType ts = foldl (==>) (ADT name $ map VarT xs) ts in

295−getDatatypeInfo _ = Nothing

279+ do schemes <- mapM (toScheme . second toType) tcs

280+ return (Map.empty, Set.empty, schemes)

281+

282+ ExportEvent js elm tipe ->

283+ do x <- guid

284+ return ( Map.singleton elm [x]

285+ , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe

286+ , [] )

287+

288+ ImportEvent js e@(C txt span base) elm tipe ->

289+ do (as,cs,t) <- gen e

290+ return ( as

291+ , Set.insert (C txt span (signalOf t :=: tipe)) cs

292+ , [ (elm, Forall [] [] tipe) ] )

293+

294+toScheme :: (String,Type) -> GuidCounter (String,Scheme)

295+toScheme (name,tipe) = do scheme <- generalize [] (Forall [] [] tipe)

296+ return (name, scheme)

elm/src/Types/Hints.hs+2

@@ -8,6 +8,8 @@ import Types.Substitutions (rescheme)

8

9ctx str = C (Just str) NoSpan

10prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs

11+hasType t = map (-: t)

12+

11

13

12-------- Text and Elements --------

14-------- Text and Elements --------

13

15

elm/src/Types/Substitutions.hs+6−5

@@ -1,9 +1,10 @@

1

2−module Types.Substitutions (subst

2+module Types.Substitutions (subst,

3− ,occurs

3+ occurs,

4+ freeVars,

4− ,concretize

5+ concretize,

5− ,rescheme

6+ rescheme,

6− ,generalize) where

7+ generalize) where

7

8

8import Context

9import Context

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

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

elm/src/Types/Types.hs−2

@@ -82,8 +82,6 @@ t1 ==> t2 = LambdaT t1 t2

82infix 8 -:

83name -: tipe = (,) name $ Forall [] [] tipe

84

85−hasType t = map (-: t)

86−

87parens = ("("++) . (++")")

85parens = ("("++) . (++")")

88

86

89instance Show Type where

87instance Show Type where