Add the Docs.hs file that extracts type annotations.
This commit is contained in:
parent
1b3480a522
commit
42b4d5531f
7 changed files with 125 additions and 49 deletions
5
Build.hs
5
Build.hs
|
@ -10,6 +10,7 @@ import System.IO
|
||||||
import Language.Elm
|
import Language.Elm
|
||||||
|
|
||||||
rts = "compiler" </> "elm-runtime.js"
|
rts = "compiler" </> "elm-runtime.js"
|
||||||
|
types = "compiler" </> "types.json"
|
||||||
|
|
||||||
getFiles ext dir = do
|
getFiles ext dir = do
|
||||||
contents <- map (dir </>) `fmap` getDirectoryContents dir
|
contents <- map (dir </>) `fmap` getDirectoryContents dir
|
||||||
|
@ -34,10 +35,12 @@ main = do
|
||||||
writeFile rts "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
|
writeFile rts "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
|
||||||
\Elm.Graphics = {}; ElmRuntime = {}; ElmRuntime.Render = {}\n"
|
\Elm.Graphics = {}; ElmRuntime = {}; ElmRuntime.Render = {}\n"
|
||||||
mapM_ appendJS =<< getFiles ".js" "libraries"
|
mapM_ appendJS =<< getFiles ".js" "libraries"
|
||||||
mapM_ appendElm =<< getFiles ".elm" "libraries"
|
files <- getFiles ".elm" "libraries"
|
||||||
|
mapM_ appendElm files
|
||||||
mapM_ appendJS =<< getFiles ".js" "runtime"
|
mapM_ appendJS =<< getFiles ".js" "runtime"
|
||||||
putStrLn "\n+------------------------------------------+\
|
putStrLn "\n+------------------------------------------+\
|
||||||
\\n| Success building runtime and libraries! |\
|
\\n| Success building runtime and libraries! |\
|
||||||
\\n+------------------------------------------+\n"
|
\\n+------------------------------------------+\n"
|
||||||
|
system ("elm-doc " ++ unwords files ++ " > " ++ types)
|
||||||
system ("cabal install compiler" </> "Elm.cabal")
|
system ("cabal install compiler" </> "Elm.cabal")
|
||||||
exitSuccess
|
exitSuccess
|
|
@ -66,10 +66,10 @@ Library
|
||||||
containers >= 0.3,
|
containers >= 0.3,
|
||||||
transformers >= 0.2,
|
transformers >= 0.2,
|
||||||
mtl >= 2,
|
mtl >= 2,
|
||||||
|
deepseq,
|
||||||
parsec >= 3.1.1,
|
parsec >= 3.1.1,
|
||||||
blaze-html == 0.5.*,
|
blaze-html == 0.5.*,
|
||||||
blaze-markup == 0.5.1.*,
|
blaze-markup == 0.5.1.*,
|
||||||
deepseq,
|
|
||||||
text,
|
text,
|
||||||
template-haskell,
|
template-haskell,
|
||||||
shakespeare >= 1,
|
shakespeare >= 1,
|
||||||
|
@ -115,13 +115,32 @@ Executable elm
|
||||||
containers >= 0.3,
|
containers >= 0.3,
|
||||||
transformers >= 0.2,
|
transformers >= 0.2,
|
||||||
mtl >= 2,
|
mtl >= 2,
|
||||||
|
deepseq,
|
||||||
parsec >= 3.1.1,
|
parsec >= 3.1.1,
|
||||||
blaze-html == 0.5.*,
|
blaze-html == 0.5.*,
|
||||||
blaze-markup == 0.5.1.*,
|
blaze-markup == 0.5.1.*,
|
||||||
deepseq,
|
|
||||||
cmdargs,
|
cmdargs,
|
||||||
pandoc >= 1.10,
|
pandoc >= 1.10,
|
||||||
bytestring,
|
bytestring,
|
||||||
hjsmin,
|
hjsmin,
|
||||||
indents,
|
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
|
|
@ -73,24 +73,26 @@ plist = foldr pcons pnil
|
||||||
ptuple es = PData ("Tuple" ++ show (length es)) es
|
ptuple es = PData ("Tuple" ++ show (length es)) es
|
||||||
|
|
||||||
brkt s = "{ " ++ s ++ " }"
|
brkt s = "{ " ++ s ++ " }"
|
||||||
|
parensIf b s = if b then parens s else s
|
||||||
|
|
||||||
instance Show Pattern where
|
instance Show Pattern where
|
||||||
show (PRecord fs) = brkt (intercalate ", " fs)
|
show p =
|
||||||
show (PVar x) = x
|
case p of
|
||||||
show PAnything = "_"
|
PRecord fs -> brkt (intercalate ", " fs)
|
||||||
show (PData "Cons" [hd@(PData "Cons" _),tl]) =
|
PVar x -> x
|
||||||
parens (show hd) ++ " : " ++ show tl
|
PAnything -> "_"
|
||||||
where parens s = "(" ++ s ++ ")"
|
PData "Cons" [hd@(PData "Cons" _),tl] ->
|
||||||
show (PData "Cons" [hd,tl]) = show hd ++ " : " ++ show tl
|
parens (show hd) ++ " :: " ++ show tl
|
||||||
show (PData "Nil" []) = "[]"
|
PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl
|
||||||
show (PData name ps) =
|
PData "Nil" [] -> "[]"
|
||||||
|
PData name ps ->
|
||||||
if take 5 name == "Tuple" && all isDigit (drop 5 name) then
|
if take 5 name == "Tuple" && all isDigit (drop 5 name) then
|
||||||
parens . intercalate ", " $ map show ps
|
parens . intercalate ", " $ map show ps
|
||||||
else (if null ps then id else parens) $ unwords (name : map show ps)
|
else parensIf (not (null ps)) $ unwords (name : map show ps)
|
||||||
where parens s = "(" ++ s ++ ")"
|
|
||||||
|
|
||||||
instance Show Expr where
|
instance Show Expr where
|
||||||
show e =
|
show e =
|
||||||
|
let show' (C _ _ e) = parensIf (needsParens e) (show e) in
|
||||||
case e of
|
case e of
|
||||||
IntNum n -> show n
|
IntNum n -> show n
|
||||||
FloatNum n -> show n
|
FloatNum n -> show n
|
||||||
|
@ -138,13 +140,13 @@ getLambdas (C _ _ (Lambda x e)) = (x:xs,e')
|
||||||
where (xs,e') = getLambdas e
|
where (xs,e') = getLambdas e
|
||||||
getLambdas e = ([],e)
|
getLambdas e = ([],e)
|
||||||
|
|
||||||
show' (C _ _ e) = if needsParens e then "(" ++ show e ++ ")" else show e
|
needsParens e =
|
||||||
|
case e of
|
||||||
needsParens (Binop _ _ _) = True
|
Binop _ _ _ -> True
|
||||||
needsParens (Lambda _ _) = True
|
Lambda _ _ -> True
|
||||||
needsParens (App _ _) = True
|
App _ _ -> True
|
||||||
needsParens (If _ _ _) = True
|
If _ _ _ -> True
|
||||||
needsParens (Let _ _) = True
|
Let _ _ -> True
|
||||||
needsParens (Case _ _) = True
|
Case _ _ -> True
|
||||||
needsParens (Data name (x:xs)) = name /= "Cons"
|
Data name (x:xs) -> name /= "Cons"
|
||||||
needsParens _ = False
|
_ -> False
|
||||||
|
|
|
@ -6,6 +6,7 @@ import Data.List (intersect, intercalate)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Version (showVersion)
|
import Data.Version (showVersion)
|
||||||
import System.Console.CmdArgs
|
import System.Console.CmdArgs
|
||||||
|
import System.Exit
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import Text.Blaze.Html.Renderer.String (renderHtml)
|
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))
|
return (fmap (:[]) (buildFromSource src))
|
||||||
jss <- concat `fmap` mapM readFile jsFiles
|
jss <- concat `fmap` mapM readFile jsFiles
|
||||||
case ems of
|
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 ->
|
Right ms ->
|
||||||
let path = fromMaybe "" outputDir </> file
|
let path = fromMaybe "" outputDir </> file
|
||||||
js = replaceExtension path ".js"
|
js = replaceExtension path ".js"
|
||||||
|
|
49
compiler/src/Docs.hs
Normal file
49
compiler/src/Docs.hs
Normal file
|
@ -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
|
|
@ -86,28 +86,29 @@ parens = ("("++) . (++")")
|
||||||
|
|
||||||
instance Show Type where
|
instance Show Type where
|
||||||
show t =
|
show t =
|
||||||
case t of
|
let show' t = case t of { LambdaT _ _ -> parens (show t) ; _ -> show t }
|
||||||
{ LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
|
in case t of
|
||||||
; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
|
LambdaT t1@(LambdaT _ _) t2 -> show' t1 ++ " -> " ++ show t2
|
||||||
; VarT x -> 't' : show x
|
LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
|
||||||
; ADT "List" [ADT "Char" []] -> "String"
|
VarT x -> 't' : show x
|
||||||
; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
|
ADT "List" [ADT "Char" []] -> "String"
|
||||||
; ADT name cs ->
|
ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
|
||||||
if isTupleString name
|
ADT name cs ->
|
||||||
then parens . intercalate "," $ map show cs
|
if isTupleString name
|
||||||
else case cs of
|
then parens . intercalate "," $ map show cs
|
||||||
[] -> name
|
else case cs of
|
||||||
_ -> parens $ name ++ " " ++ unwords (map show cs)
|
[] -> name
|
||||||
; Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
|
_ -> name ++ " " ++ unwords (map show cs)
|
||||||
; EmptyRecord -> "{}"
|
Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
|
||||||
; RecordT fs t ->
|
EmptyRecord -> "{}"
|
||||||
start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
|
RecordT fs t ->
|
||||||
where field n s = n ++ " :: " ++ show s
|
start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
|
||||||
fields (n,ss) = map (field n) ss
|
where field n s = n ++ " :: " ++ show s
|
||||||
start = case t of
|
fields (n,ss) = map (field n) ss
|
||||||
EmptyRecord -> "{ "
|
start = case t of
|
||||||
_ -> "{ " ++ show t ++ " | "
|
EmptyRecord -> "{ "
|
||||||
}
|
_ -> "{ " ++ show t ++ " | "
|
||||||
|
|
||||||
|
|
||||||
instance Show Scheme where
|
instance Show Scheme where
|
||||||
show (Forall [] [] t) = show t
|
show (Forall [] [] t) = show t
|
||||||
|
|
Loading…
Reference in a new issue