Add the Docs.hs file that extracts type annotations.

Build.hs

@@ -10,6 +10,7 @@ import System.IO
 import Language.Elm
 
 rts = "compiler" </> "elm-runtime.js"
+types = "compiler" </> "types.json"
 
 getFiles ext dir = do
   contents <- map (dir </>) `fmap` getDirectoryContents dir
@@ -34,10 +35,12 @@ main = do
   writeFile rts "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
                 \Elm.Graphics = {}; ElmRuntime = {}; ElmRuntime.Render = {}\n"
   mapM_ appendJS  =<< getFiles ".js"  "libraries"
-  mapM_ appendElm =<< getFiles ".elm" "libraries"
+  files <- getFiles ".elm" "libraries"
+  mapM_ appendElm files
   mapM_ appendJS  =<< getFiles ".js"  "runtime"
   putStrLn "\n+------------------------------------------+\
            \\n|  Success building runtime and libraries! |\
            \\n+------------------------------------------+\n"
+  system ("elm-doc " ++ unwords files ++ " > " ++ types)
   system ("cabal install compiler" </> "Elm.cabal")
   exitSuccess

compiler/Elm.cabal

@@ -66,10 +66,10 @@ Library
                        containers >= 0.3,
                        transformers >= 0.2,
                        mtl >= 2,
+                       deepseq,
                        parsec >= 3.1.1,
                        blaze-html == 0.5.*,
                        blaze-markup == 0.5.1.*,
-                       deepseq,
                        text,
                        template-haskell,
                        shakespeare >= 1,
@@ -115,13 +115,32 @@ Executable elm
                        containers >= 0.3,
                        transformers >= 0.2,
                        mtl >= 2,
+                       deepseq,
                        parsec >= 3.1.1,
                        blaze-html == 0.5.*,
                        blaze-markup == 0.5.1.*,
-                       deepseq,
                        cmdargs,
                        pandoc >= 1.10,
                        bytestring,
                        hjsmin,
                        indents,
-                       filepath
+                       filepath
+
+Executable elm-doc
+  Main-is:             Docs.hs
+  Hs-Source-Dirs:      src
+  other-modules:       Ast,
+                       Context,
+                       Parse.Library,
+                       Parse.Modules,
+                       Parse.Types,
+                       Types.Types
+
+  Build-depends:       base >=4.2 && <5,
+                       containers >= 0.3,
+                       transformers >= 0.2,
+                       mtl >= 2,
+                       parsec >= 3.1.1,
+                       pandoc >= 1.10,
+                       cmdargs,
+                       indents

compiler/src/Ast.hs

@@ -73,24 +73,26 @@ plist     = foldr pcons pnil
 ptuple es = PData ("Tuple" ++ show (length es)) es
 
 brkt s = "{ " ++ s ++ " }"
+parensIf b s = if b then parens s else s
 
 instance Show Pattern where
-    show (PRecord fs) = brkt (intercalate ", " fs)
-    show (PVar x)  = x
-    show PAnything = "_"
-    show (PData "Cons" [hd@(PData "Cons" _),tl]) =
-        parens (show hd) ++ " : " ++ show tl
-            where parens s = "(" ++ s ++ ")"
-    show (PData "Cons" [hd,tl]) = show hd ++ " : " ++ show tl
-    show (PData "Nil" []) = "[]"
-    show (PData name ps) =
+  show p =
+   case p of
+     PRecord fs -> brkt (intercalate ", " fs)
+     PVar x -> x
+     PAnything -> "_"
+     PData "Cons" [hd@(PData "Cons" _),tl] ->
+        parens (show hd) ++ " :: " ++ show tl
+     PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl
+     PData "Nil" [] -> "[]"
+     PData name ps ->
         if take 5 name == "Tuple" && all isDigit (drop 5 name) then
             parens . intercalate ", " $ map show ps
-        else (if null ps then id else parens) $ unwords (name : map show ps)
-            where parens s = "(" ++ s ++ ")"
+        else parensIf (not (null ps)) $ unwords (name : map show ps)
 
 instance Show Expr where
   show e =
+   let show' (C _ _ e) = parensIf (needsParens e) (show e) in
    case e of
      IntNum n -> show n
      FloatNum n -> show n
@@ -138,13 +140,13 @@ getLambdas (C _ _ (Lambda x e)) = (x:xs,e')
     where (xs,e') = getLambdas e
 getLambdas e = ([],e)
 
-show' (C _ _ e) = if needsParens e then "(" ++ show e ++ ")" else show e
-
-needsParens (Binop _ _ _) = True
-needsParens (Lambda _ _) = True
-needsParens (App _ _) = True
-needsParens (If _ _ _) = True
-needsParens (Let _ _) = True
-needsParens (Case _ _) = True
-needsParens (Data name (x:xs)) = name /= "Cons"
-needsParens _ = False
+needsParens e =
+  case e of
+    Binop _ _ _ -> True
+    Lambda _ _ -> True
+    App _ _ -> True
+    If _ _ _ -> True
+    Let _ _ -> True
+    Case _ _ -> True
+    Data name (x:xs) -> name /= "Cons"
+    _ -> False

compiler/src/Compiler.hs

@@ -6,6 +6,7 @@ import Data.List (intersect, intercalate)
 import Data.Maybe (fromMaybe)
 import Data.Version (showVersion)
 import System.Console.CmdArgs
+import System.Exit
 import System.FilePath
 import Text.Blaze.Html.Renderer.String (renderHtml)
 
@@ -68,7 +69,8 @@ fileTo isMini make what jsFiles noscript outputDir rtLoc file = do
                                          return (fmap (:[]) (buildFromSource src))
   jss <- concat `fmap` mapM readFile jsFiles
   case ems of
-    Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
+    Left err -> do putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
+                   exitFailure
     Right ms ->
         let path = fromMaybe "" outputDir </> file
             js = replaceExtension path ".js"

compiler/src/Docs.hs

@@ -0,0 +1,49 @@
+
+module Main where
+
+import Ast
+import Control.Applicative ((<$>), (<*>))
+import Data.List as List
+import Parse.Library
+import Parse.Modules (moduleDef)
+import Parse.Types (typeAnnotation)
+import System.Environment
+import System.Exit
+import Text.Parsec hiding (newline,spaces)
+import Types.Types
+
+
+main = do
+  srcs <- mapM readFile =<< getArgs
+  case mapM docParse srcs of
+    Left err -> putStrLn err >> exitFailure
+    Right ms -> putStrLn (toModules ms)
+
+toModules ms =
+  "{ \"modules\" : [\n    " ++ intercalate ",\n    " (map toModule ms) ++ "\n  ]\n}"
+
+toModule (name, values) =
+  "{ \"module\" : " ++ show name ++ ",\n      \"values\" : [\n        " ++ vs ++ "\n      ]\n    }"
+    where vs = intercalate ",\n        " (map toValue values)
+
+toValue (name, tipe) =
+    "{ \"name\" : " ++ show name ++ ",\n          \"type\" : \"" ++ show tipe ++ "\"\n        }"
+
+docParse :: String -> Either String (String, [(String, Type)])
+docParse = setupParser $ do
+             optional freshLine
+             (,) <$> option "Main" moduleName <*> types
+    where 
+      skip = manyTill anyChar simpleNewline >> return []
+      end  = many1 anyChar >> return []
+      tipe = get <$> try typeAnnotation
+      get stmt = case stmt of { TypeAnnotation n t -> [(n,t)] ; _ -> [] }
+      types = concat <$> many (tipe <|> try skip <|> end)
+      getName = intercalate "." . fst
+      moduleName = do optional freshLine 
+                      getName <$> moduleDef `followedBy` freshLine
+
+setupParser p source =
+    case iParse p "" source of
+      Right result -> Right result
+      Left err -> Left $ "Parse error at " ++ show err

compiler/src/Types/Types.hs

@@ -86,28 +86,29 @@ parens = ("("++) . (++")")
 
 instance Show Type where
   show t =
-      case t of
-        { LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
-        ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
-        ; VarT x -> 't' : show x
-        ; ADT "List" [ADT "Char" []] -> "String"
-        ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
-        ; ADT name cs ->
-            if isTupleString name
-                then parens . intercalate "," $ map show cs
-                else case cs of
-                       [] -> name
-                       _ -> parens $ name ++ " " ++ unwords (map show cs)
-        ; Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
-        ; EmptyRecord -> "{}"
-        ; RecordT fs t ->
-            start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
-                where field n s = n ++ " :: " ++ show s
-                      fields (n,ss) = map (field n) ss
-                      start = case t of
-                                EmptyRecord -> "{ "
-                                _ -> "{ " ++ show t ++ " | "
-        }
+   let show' t = case t of { LambdaT _ _ -> parens (show t) ; _ -> show t }
+   in case t of
+      LambdaT t1@(LambdaT _ _) t2 -> show' t1 ++ " -> " ++ show t2
+      LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
+      VarT x -> 't' : show x
+      ADT "List" [ADT "Char" []] -> "String"
+      ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
+      ADT name cs ->
+          if isTupleString name
+              then parens . intercalate "," $ map show cs
+              else case cs of
+                     [] -> name
+                     _  -> name ++ " " ++ unwords (map show cs)
+      Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
+      EmptyRecord -> "{}"
+      RecordT fs t ->
+        start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
+           where field n s = n ++ " :: " ++ show s
+                 fields (n,ss) = map (field n) ss
+                 start = case t of
+                           EmptyRecord -> "{ "
+                           _ -> "{ " ++ show t ++ " | "
+
 
 instance Show Scheme where
   show (Forall [] [] t) = show t

libraries/Graphics/Color.elm

@@ -47,4 +47,4 @@ data Gradient
   | Radial [(Float,Color)] (Float,Float) Float (Float,Float) Float
 
 linear = Linear
-radial = Radial
+radial = Radial