f27453e · elk · git.iko.soy

git.iko.soy/elk

Add support for `[markdown| anything can go here |] :: Element`. Yay!

commitf27453e175a29b921feadf95201c6325ad8f03bb authorevancz <info@elm-lang.org> dateSun 2 Sep 2012, 00:26 (14 years ago) parent2f5d445

9 files changed+64−16

compare with master

unifiedsplit

elm/Elm.cabal+4−2 elm/src/Ast.hs+2 elm/src/Gen/CompileToJS.hs+11−3 elm/src/Gen/ExtractNoscript.hs+2 elm/src/Parse/ParseExpr.hs+10−5 elm/src/Substitute.hs+26 elm/src/Types/Constrain.hs+1 elm/src/Types/Hints.hs+6−4 elm/src/Types/Unify.hs+2−2

elm/Elm.cabal+4−2

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

6767 deepseq,

6868 text,

6969 template-haskell,

70− shakespeare

70+ shakespeare,

71+ pandoc

7172

7273Executable elm

7374 Main-is: Compiler.hs

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

104105 blaze-html == 0.5.0.*,

105106 blaze-markup == 0.5.1.*,

106107 deepseq,

107− cmdargs

108+ cmdargs,

109+ pandoc

elm/src/Ast.hs+2

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

55import Data.List (intercalate)

66import Types

77import Guid

8+import qualified Text.Pandoc as Pandoc

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

1011

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

3637 | Var String

3738 | Case Expr [(Pattern,Expr)]

3839 | Data String [Expr]

40+ | Markdown Pandoc.Pandoc

3941 deriving (Eq)

4042

4143data Definition = Definition String [String] Expr

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

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

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

99import Data.Map (toList)

1010import Data.Maybe (mapMaybe)

11+import qualified Text.Pandoc as Pan

1112

1213import Initialize

1314import Rename (derename)

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

141142 Let defs e -> jsLet defs e

142143 Case e cases -> caseToJS e cases

143144 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>')" ]

144149

145150jsLet defs e' = do

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

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

156161

157162caseToJS e ps = do

158163 match <- caseToMatch ps

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

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

160165 matches <- matchToJS var match

161166 e' <- toJS' e

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

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

176181clauseToJS var (Clause name vars e) = do

177182 s <- matchToJS var e

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

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

184+ , defs

180185 , 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 ]

182190

183191jsNil = "[\"Nil\"]"

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

elm/src/Gen/ExtractNoscript.hs+2

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

22module ExtractNoscript (extract) where

44import Ast

5+import qualified Text.Pandoc as Pan

67extract (Module _ _ _ stmts) =

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

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

3031 Var _ -> []

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

3233 Data _ es -> concatMap f es

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

3335 _ -> []

3436

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

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

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

66import Data.Char (isSymbol, isDigit)

77import Data.List (foldl')

88import Text.Parsec hiding (newline,spaces)

9+import qualified Text.Pandoc as Pan

910

1011import ParseLib

1112import Patterns

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

1415import Guid

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

1617

18+import System.IO.Unsafe

19+

1720

1821-------- Basic Terms --------

1922

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

4447

4548-------- Complex Terms --------

4649

47−listTerm = braces $ choice

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

49− ; Range lo <$> expr }

50− , list <$> commaSep expr

51− ]

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

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

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

53+ <|> (braces $ choice

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

55+ ; Range lo <$> expr }

56+ , list <$> commaSep expr ])

5257

5358parensTerm = parens $ choice

5459 [ do op <- anyOp

elm/src/Substitute.hsnew file+26

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

1+module Substitute (subst) where

3+import Control.Arrow (second)

5+import Ast

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 =

100100 Chr _ -> primitive char

101101 Str _ -> primitive string

102102 Boolean _ -> primitive bool

103+ Markdown _ -> primitive element

103104 _ -> beta >>= primitive

104105

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

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

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

1010-------- Text and Elements --------

1111

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

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

1313

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

1515 , "overline", "strikeThrough", "monospace" ]

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

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

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

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

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

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

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

2729 , "width" -: iee

2830 , "height" -: iee

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

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

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

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

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

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

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

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

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

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

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

5961 , "rect"

6062 , "oval" ]

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

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

7979

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

8181 | 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)

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

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

8585 f _ = False

8686

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

8888 | Set.member t ts = solver cs subs

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

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

9090

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

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