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
|
||||
|
||||
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
|
|
@ -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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
|
|
@ -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"
|
||||
|
|
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
|
||||
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
|
||||
|
|
Loading…
Reference in a new issue