git.iko.soy/elk
on master help sign in
Add the Docs.hs file that extracts type annotations.
commit42b4d5531f7230bde543bf74459601ea26977116 authorevancz <info@elm-lang.org> dateThu 14 Mar 2013, 01:04 (14 years ago) parent1b3480a
7 files changed+125−49
compare with master
unifiedsplit
Build.hs+4−1 compiler/Elm.cabal+22−3 compiler/src/Ast.hs+23−21 compiler/src/Compiler.hs+3−1 compiler/src/Docs.hs+49 compiler/src/Types/Types.hs+23−22 libraries/Graphics/Color.elm+1−1
Build.hs+4−1
@@ -10,6 +10,7 @@ import System.IO
1010import Language.Elm
1111
1212rts = "compiler" </> "elm-runtime.js"
13+types = "compiler" </> "types.json"
1314
1415getFiles ext dir = do
1516 contents <- map (dir </>) `fmap` getDirectoryContents dir
@@ -34,10 +35,12 @@ main = do
3435 writeFile rts "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
3536 \Elm.Graphics = {}; ElmRuntime = {}; ElmRuntime.Render = {}\n"
3637 mapM_ appendJS =<< getFiles ".js" "libraries"
37− mapM_ appendElm =<< getFiles ".elm" "libraries"
38+ files <- getFiles ".elm" "libraries"
39+ mapM_ appendElm files
3840 mapM_ appendJS =<< getFiles ".js" "runtime"
3941 putStrLn "\n+------------------------------------------+\
4042 \\n| Success building runtime and libraries! |\
4143 \\n+------------------------------------------+\n"
44+ system ("elm-doc " ++ unwords files ++ " > " ++ types)
4245 system ("cabal install compiler" </> "Elm.cabal")
4346 exitSuccess
compiler/Elm.cabal+22−3
@@ -66,10 +66,10 @@ Library
6666 containers >= 0.3,
6767 transformers >= 0.2,
6868 mtl >= 2,
69+ deepseq,
6970 parsec >= 3.1.1,
7071 blaze-html == 0.5.*,
7172 blaze-markup == 0.5.1.*,
72− deepseq,
7373 text,
7474 template-haskell,
7575 shakespeare >= 1,
@@ -115,13 +115,32 @@ Executable elm
115115 containers >= 0.3,
116116 transformers >= 0.2,
117117 mtl >= 2,
118+ deepseq,
118119 parsec >= 3.1.1,
119120 blaze-html == 0.5.*,
120121 blaze-markup == 0.5.1.*,
121− deepseq,
122122 cmdargs,
123123 pandoc >= 1.10,
124124 bytestring,
125125 hjsmin,
126126 indents,
127− filepath
127+ filepath
128+
129+Executable elm-doc
130+ Main-is: Docs.hs
131+ Hs-Source-Dirs: src
132+ other-modules: Ast,
133+ Context,
134+ Parse.Library,
135+ Parse.Modules,
136+ Parse.Types,
137+ Types.Types
138+
139+ Build-depends: base >=4.2 && <5,
140+ containers >= 0.3,
141+ transformers >= 0.2,
142+ mtl >= 2,
143+ parsec >= 3.1.1,
144+ pandoc >= 1.10,
145+ cmdargs,
146+ indents
compiler/src/Ast.hs+23−21
@@ -73,24 +73,26 @@ plist = foldr pcons pnil
7373ptuple es = PData ("Tuple" ++ show (length es)) es
7474
7575brkt s = "{ " ++ s ++ " }"
76+parensIf b s = if b then parens s else s
7677
7778instance Show Pattern where
78− show (PRecord fs) = brkt (intercalate ", " fs)
79− show (PVar x) = x
80− show PAnything = "_"
81− show (PData "Cons" [hd@(PData "Cons" _),tl]) =
82− parens (show hd) ++ " : " ++ show tl
83− where parens s = "(" ++ s ++ ")"
84− show (PData "Cons" [hd,tl]) = show hd ++ " : " ++ show tl
85− show (PData "Nil" []) = "[]"
86− show (PData name ps) =
79+ show p =
80+ case p of
81+ PRecord fs -> brkt (intercalate ", " fs)
82+ PVar x -> x
83+ PAnything -> "_"
84+ PData "Cons" [hd@(PData "Cons" _),tl] ->
85+ parens (show hd) ++ " :: " ++ show tl
86+ PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl
87+ PData "Nil" [] -> "[]"
88+ PData name ps ->
8789 if take 5 name == "Tuple" && all isDigit (drop 5 name) then
8890 parens . intercalate ", " $ map show ps
89− else (if null ps then id else parens) $ unwords (name : map show ps)
90− where parens s = "(" ++ s ++ ")"
91+ else parensIf (not (null ps)) $ unwords (name : map show ps)
9192
9293instance Show Expr where
9394 show e =
95+ let show' (C _ _ e) = parensIf (needsParens e) (show e) in
9496 case e of
9597 IntNum n -> show n
9698 FloatNum n -> show n
@@ -138,13 +140,13 @@ getLambdas (C _ _ (Lambda x e)) = (x:xs,e')
138140 where (xs,e') = getLambdas e
139141getLambdas e = ([],e)
140142
141−show' (C _ _ e) = if needsParens e then "(" ++ show e ++ ")" else show e
142−
143−needsParens (Binop _ _ _) = True
144−needsParens (Lambda _ _) = True
145−needsParens (App _ _) = True
146−needsParens (If _ _ _) = True
147−needsParens (Let _ _) = True
148−needsParens (Case _ _) = True
149−needsParens (Data name (x:xs)) = name /= "Cons"
150−needsParens _ = False
143+needsParens e =
144+ case e of
145+ Binop _ _ _ -> True
146+ Lambda _ _ -> True
147+ App _ _ -> True
148+ If _ _ _ -> True
149+ Let _ _ -> True
150+ Case _ _ -> True
151+ Data name (x:xs) -> name /= "Cons"
152+ _ -> False
compiler/src/Compiler.hs+3−1
@@ -6,6 +6,7 @@ import Data.List (intersect, intercalate)
66import Data.Maybe (fromMaybe)
77import Data.Version (showVersion)
88import System.Console.CmdArgs
9+import System.Exit
910import System.FilePath
1011import Text.Blaze.Html.Renderer.String (renderHtml)
1112
@@ -68,7 +69,8 @@ fileTo isMini make what jsFiles noscript outputDir rtLoc file = do
6869 return (fmap (:[]) (buildFromSource src))
6970 jss <- concat `fmap` mapM readFile jsFiles
7071 case ems of
71− Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
72+ Left err -> do putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
73+ exitFailure
7274 Right ms ->
7375 let path = fromMaybe "" outputDir </> file
7476 js = replaceExtension path ".js"
compiler/src/Docs.hsnew file+49
@@ -0,0 +1,49 @@
1+
2+module Main where
3+
4+import Ast
5+import Control.Applicative ((<$>), (<*>))
6+import Data.List as List
7+import Parse.Library
8+import Parse.Modules (moduleDef)
9+import Parse.Types (typeAnnotation)
10+import System.Environment
11+import System.Exit
12+import Text.Parsec hiding (newline,spaces)
13+import Types.Types
14+
15+
16+main = do
17+ srcs <- mapM readFile =<< getArgs
18+ case mapM docParse srcs of
19+ Left err -> putStrLn err >> exitFailure
20+ Right ms -> putStrLn (toModules ms)
21+
22+toModules ms =
23+ "{ \"modules\" : [\n " ++ intercalate ",\n " (map toModule ms) ++ "\n ]\n}"
24+
25+toModule (name, values) =
26+ "{ \"module\" : " ++ show name ++ ",\n \"values\" : [\n " ++ vs ++ "\n ]\n }"
27+ where vs = intercalate ",\n " (map toValue values)
28+
29+toValue (name, tipe) =
30+ "{ \"name\" : " ++ show name ++ ",\n \"type\" : \"" ++ show tipe ++ "\"\n }"
31+
32+docParse :: String -> Either String (String, [(String, Type)])
33+docParse = setupParser $ do
34+ optional freshLine
35+ (,) <$> option "Main" moduleName <*> types
36+ where
37+ skip = manyTill anyChar simpleNewline >> return []
38+ end = many1 anyChar >> return []
39+ tipe = get <$> try typeAnnotation
40+ get stmt = case stmt of { TypeAnnotation n t -> [(n,t)] ; _ -> [] }
41+ types = concat <$> many (tipe <|> try skip <|> end)
42+ getName = intercalate "." . fst
43+ moduleName = do optional freshLine
44+ getName <$> moduleDef `followedBy` freshLine
45+
46+setupParser p source =
47+ case iParse p "" source of
48+ Right result -> Right result
49+ Left err -> Left $ "Parse error at " ++ show err
compiler/src/Types/Types.hs+23−22
@@ -86,28 +86,29 @@ parens = ("("++) . (++")")
8686
8787instance Show Type where
8888 show t =
89− case t of
90− { LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
91− ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
92− ; VarT x -> 't' : show x
93− ; ADT "List" [ADT "Char" []] -> "String"
94− ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
95− ; ADT name cs ->
96− if isTupleString name
97− then parens . intercalate "," $ map show cs
98− else case cs of
99− [] -> name
100− _ -> parens $ name ++ " " ++ unwords (map show cs)
101− ; Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
102− ; EmptyRecord -> "{}"
103− ; RecordT fs t ->
104− start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
105− where field n s = n ++ " :: " ++ show s
106− fields (n,ss) = map (field n) ss
107− start = case t of
108− EmptyRecord -> "{ "
109− _ -> "{ " ++ show t ++ " | "
110− }
89+ let show' t = case t of { LambdaT _ _ -> parens (show t) ; _ -> show t }
90+ in case t of
91+ LambdaT t1@(LambdaT _ _) t2 -> show' t1 ++ " -> " ++ show t2
92+ LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
93+ VarT x -> 't' : show x
94+ ADT "List" [ADT "Char" []] -> "String"
95+ ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
96+ ADT name cs ->
97+ if isTupleString name
98+ then parens . intercalate "," $ map show cs
99+ else case cs of
100+ [] -> name
101+ _ -> name ++ " " ++ unwords (map show cs)
102+ Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
103+ EmptyRecord -> "{}"
104+ RecordT fs t ->
105+ start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
106+ where field n s = n ++ " :: " ++ show s
107+ fields (n,ss) = map (field n) ss
108+ start = case t of
109+ EmptyRecord -> "{ "
110+ _ -> "{ " ++ show t ++ " | "
111+
111112
112113instance Show Scheme where
113114 show (Forall [] [] t) = show t
libraries/Graphics/Color.elm+1−1
@@ -47,4 +47,4 @@ data Gradient
4747 | Radial [(Float,Color)] (Float,Float) Float (Float,Float) Float
4848
4949linear = Linear
50−radial = Radial
50+radial = Radial