f27453e · elk · git.iko.soy

elm/Elm.cabal+4−2

compare with master

unifiedsplit

@@ -67,7 +67,8 @@ Library

67 deepseq,

68 text,

69 template-haskell,

70− shakespeare

70+ shakespeare,

71+ pandoc

71

72

72Executable elm

73Executable elm

73 Main-is: Compiler.hs

74 Main-is: Compiler.hs

@@ -104,4 +105,5 @@ Executable elm

104 blaze-html == 0.5.0.*,

105 blaze-html == 0.5.0.*,

105 blaze-markup == 0.5.1.*,

106 blaze-markup == 0.5.1.*,

106 deepseq,

107 deepseq,

107− cmdargs

108+ cmdargs,

109+ pandoc

elm/src/Ast.hs+2

@@ -5,6 +5,7 @@ import Data.Char (isDigit)

5import Data.List (intercalate)

6import Types

7import Guid

8+import qualified Text.Pandoc as Pandoc

8

9

9data Module = Module [String] Exports Imports [Statement]

10data Module = Module [String] Exports Imports [Statement]

10

11

@@ -36,6 +37,7 @@ data Expr = IntNum Int

36 | Var String

37 | Var String

37 | Case Expr [(Pattern,Expr)]

38 | Case Expr [(Pattern,Expr)]

38 | Data String [Expr]

39 | Data String [Expr]

40+ | Markdown Pandoc.Pandoc

39 deriving (Eq)

41 deriving (Eq)

40

42

41data Definition = Definition String [String] Expr

43data Definition = Definition String [String] Expr

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

@@ -8,6 +8,7 @@ import Data.Char (isAlpha,isDigit)

8import Data.List (intercalate,sortBy,inits)

9import Data.Map (toList)

10import Data.Maybe (mapMaybe)

11+import qualified Text.Pandoc as Pan

11

12

12import Initialize

13import Initialize

13import Rename (derename)

14import Rename (derename)

@@ -141,6 +142,10 @@ toJS' expr =

141 Let defs e -> jsLet defs e

142 Let defs e -> jsLet defs e

142 Case e cases -> caseToJS e cases

143 Case e cases -> caseToJS e cases

143 Data name es -> (\ss -> jsList $ show name : ss) `liftM` mapM toJS' es

144 Data name es -> (\ss -> jsList $ show name : ss) `liftM` mapM toJS' es

145+ Markdown doc ->

146+ return $ concat [ "text('<div style=\"height:0;width:0;\"> </div>"

147+ , filter (/='\n') $ Pan.writeHtmlString Pan.defaultWriterOptions doc

148+ , "<div style=\"height:0;width:0;\"> </div>')" ]

144

149

145jsLet defs e' = do

150jsLet defs e' = do

146 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')

151 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')

@@ -156,7 +161,7 @@ jsDefs defs = concat `liftM` mapM toDef (sortBy f defs)

156

161

157caseToJS e ps = do

162caseToJS e ps = do

158 match <- caseToMatch ps

163 match <- caseToMatch ps

159− var <- liftM (\n -> "vv" ++ show n) guid

164+ var <- liftM (\n -> "case" ++ show n) guid

160 matches <- matchToJS var match

165 matches <- matchToJS var match

161 e' <- toJS' e

166 e' <- toJS' e

162 return $ concat [ "function(", var, "){"

167 return $ concat [ "function(", var, "){"

@@ -176,9 +181,12 @@ matchToJS v (Seq ms) = concat `liftM` mapM (matchToJS v) ms

176clauseToJS var (Clause name vars e) = do

181clauseToJS var (Clause name vars e) = do

177 s <- matchToJS var e

182 s <- matchToJS var e

178 return $ concat [ "\ncase ", show name, ":"

183 return $ concat [ "\ncase ", show name, ":"

179− , concat $ zipWith toDef vars [ 1 .. length vars ]

184+ , defs

180 , s ]

185 , s ]

181− where toDef v n = assign v (var ++ "[" ++ show n ++ "]")

186+ where toDef v n = v ++ "=" ++ var ++ "[" ++ show n ++ "]"

187+ defs = case vars of [] -> ""

188+ _ -> ("\nvar "++) . (++";") . intercalate "," $

189+ zipWith toDef vars [ 1 .. length vars ]

182

190

183jsNil = "[\"Nil\"]"

191jsNil = "[\"Nil\"]"

184jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]

192jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]

elm/src/Gen/ExtractNoscript.hs+2

@@ -2,6 +2,7 @@

2module ExtractNoscript (extract) where

3

4import Ast

5+import qualified Text.Pandoc as Pan

5

6

6extract (Module _ _ _ stmts) =

7extract (Module _ _ _ stmts) =

7 concatMap (\s -> "<p>" ++ s ++ "</p>") (concatMap stmtExtract stmts)

8 concatMap (\s -> "<p>" ++ s ++ "</p>") (concatMap stmtExtract stmts)

@@ -30,6 +31,7 @@ extract' expr =

30 Var _ -> []

31 Var _ -> []

31 Case e cases -> concatMap (f . snd) cases

32 Case e cases -> concatMap (f . snd) cases

32 Data _ es -> concatMap f es

33 Data _ es -> concatMap f es

34+ Markdown doc -> [ Pan.writeHtmlString Pan.defaultWriterOptions doc ]

33 _ -> []

35 _ -> []

34

36

35tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract' e)

37tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract' e)

elm/src/Parse/ParseExpr.hs+10−5

@@ -6,6 +6,7 @@ import Control.Monad

6import Data.Char (isSymbol, isDigit)

7import Data.List (foldl')

8import Text.Parsec hiding (newline,spaces)

9+import qualified Text.Pandoc as Pan

9

10

10import ParseLib

11import ParseLib

11import Patterns

12import Patterns

@@ -14,6 +15,8 @@ import Binops

14import Guid

15import Guid

15import Types (Type (VarT), Scheme (Forall))

16import Types (Type (VarT), Scheme (Forall))

16

17

18+import System.IO.Unsafe

19+

17

20

18-------- Basic Terms --------

21-------- Basic Terms --------

19

22

@@ -44,11 +47,13 @@ chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

44

47

45-------- Complex Terms --------

48-------- Complex Terms --------

46

49

50+listTerm = (do { try $ string "[markdown|"

51+ ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")

52+ ; return . Markdown $ Pan.readMarkdown Pan.defaultParserState md })

47−listTerm = braces $ choice

53+ <|> (braces $ choice

48− [ try $ do { lo <- expr; whitespace; string ".." ; whitespace

54+ [ try $ do { lo <- expr; whitespace; string ".." ; whitespace

49− ; Range lo <$> expr }

55+ ; Range lo <$> expr }

50− , list <$> commaSep expr

56+ , list <$> commaSep expr ])

51− ]

52

57

53parensTerm = parens $ choice

58parensTerm = parens $ choice

54 [ do op <- anyOp

59 [ do op <- anyOp

elm/src/Substitute.hsnew file+26

@@ -0,0 +1,26 @@

1+module Substitute (subst) where

2+

3+import Control.Arrow (second)

4+

5+import Ast

6+

7+subst :: String -> String -> Expr -> Expr

8+subst new old expr =

9+ let f = subst new old in

10+ case expr of

11+ Range e1 e2 -> Range (f e1) (f e2)

12+ Access e x -> Access (f e) x

13+ Binop op e1 e2 -> Binop op (f e1) (f e2)

14+ Lambda x e -> if x == old then expr else Lambda x (f e)

15+ App e1 e2 -> App (f e1) (f e2)

16+ If e1 e2 e3 -> If (f e1) (f e2) (f e3)

17+ Lift e es -> Lift (f e) (map f es)

18+ Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)

19+ Async e -> Async (f e)

20+ Input _ -> expr

21+ Let defs e -> Let (map substDef defs) (f e)

22+ where substDef (Definition name vs e) = Definition name vs (f e)

23+ Var x -> if x == old then Var new else expr

24+ Case e cases -> Case (f e) $ map (second f) cases

25+ Data name es -> Data name (map f es)

26+ _ -> expr

elm/src/Types/Constrain.hs+1

@@ -100,6 +100,7 @@ gen other =

100 Chr _ -> primitive char

101 Str _ -> primitive string

102 Boolean _ -> primitive bool

103+ Markdown _ -> primitive element

103 _ -> beta >>= primitive

104 _ -> beta >>= primitive

104

105

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

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

elm/src/Types/Hints.hs+6−4

@@ -9,7 +9,7 @@ import Types.Substitutions (rescheme)

9

10-------- Text and Elements --------

11

12−str2elem = hasType (string ==> element) [ "image","video","plainText" ]

12+str2elem = hasType (string ==> element) [ "plainText" ]

13

14textToText = [ "header", "italic", "bold", "underline"

15 , "overline", "strikeThrough", "monospace" ]

@@ -23,6 +23,8 @@ elements = let iee = int ==> element ==> element in

23 [ "flow" -: direction ==> listOf element ==> element

24 , "layers" -: listOf element ==> element

25 , "text" -: text ==> element

26+ , "image" -: int ==> int ==> string ==> element

27+ , "video" -: int ==> int ==> string ==> element

26 , "opacity" -: float ==> element ==> element

28 , "opacity" -: float ==> element ==> element

27 , "width" -: iee

29 , "width" -: iee

28 , "height" -: iee

30 , "height" -: iee

@@ -52,9 +54,9 @@ shapes = [ twoNums (\n m -> listOf (pairOf n) ==> pairOf m ==> shape) "polygon"

52 , "filled" -: color ==> shape ==> form

54 , "filled" -: color ==> shape ==> form

53 , "outlined" -: color ==> shape ==> form

55 , "outlined" -: color ==> shape ==> form

54 , "customOutline" -: listOf int ==> color ==> shape ==> form

56 , "customOutline" -: listOf int ==> color ==> shape ==> form

55− , scheme2 number transformable (\n t -> n ==> n ==> t ==> t) "move"

57+ , numScheme (\n -> n ==> n ==> form ==> form) "move"

56− , scheme2 number transformable (\n t -> n ==> t ==> t) "rotate"

58+ , numScheme (\n -> n ==> form ==> form) "rotate"

57− , scheme2 number transformable (\n t -> n ==> t ==> t) "scale"

59+ , numScheme (\n -> n ==> form ==> form) "scale"

58 ] ++ map (twoNums (\n m -> n ==> n ==> pairOf m ==> shape)) [ "ngon"

60 ] ++ map (twoNums (\n m -> n ==> n ==> pairOf m ==> shape)) [ "ngon"

59 , "rect"

61 , "rect"

60 , "oval" ]

62 , "oval" ]

elm/src/Types/Unify.hs+2−2

@@ -79,14 +79,14 @@ solver (Context ctx (VarT x :<: Super ts) : cs) subs =

79

80solver (Context ctx (ADT "List" [t] :<: Super ts) : cs) subs

81 | any f (Set.toList ts) = solver cs subs

82− | otherwise = subtypeError ("aoeu" ++ ctx) (ADT "List" [t]) (Super ts)

82+ | otherwise = subtypeError ctx (ADT "List" [t]) (Super ts)

83 where f (ADT "List" [VarT _]) = True

84 f (ADT "List" [t']) = t == t'

85 f _ = False

86

87solver (Context ctx (t :<: Super ts) : cs) subs

88 | Set.member t ts = solver cs subs

89− | otherwise = subtypeError ("htns" ++ ctx) t (Super ts)

89+ | otherwise = subtypeError ctx t (Super ts)

90

91solver (Context ctx (x :<<: s) : cs) subs

92 | any (\(Context _ c) -> x `elem` cFreeVars c) cs =