git.iko.soy/Idris-dev
on bcce759 help sign in
Idris-dev/src/Idris/Package/Parser.hs
148 lines 6.1 kB history raw
1{-|
2Module : Idris.Package.Parser
3Description : `iPKG` file parser and package description information.
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE FlexibleContexts #-}
9module Idris.Package.Parser where
11import Idris.CmdOptions
12import Idris.Imports
13import Idris.Options (Opt)
14import Idris.Package.Common
15import Idris.Parser (moduleName)
16import Idris.Parser.Helpers (Parser, Parsing, eol, iName, identifier,
17 identifierWithExtraChars, isEol, lchar,
18 packageName, parseErrorDoc, reserved, runparser,
19 someSpace, stringLiteral)
21import Control.Applicative
22import Control.Monad.State.Strict
23import Data.List (union)
24import qualified Options.Applicative as Opts
25import System.Directory (doesFileExist)
26import System.Exit
27import System.FilePath (isValid, takeExtension, takeFileName)
28import Text.Megaparsec ((<?>))
29import qualified Text.Megaparsec as P
30import qualified Text.PrettyPrint.ANSI.Leijen as PP
32type PParser = Parser PkgDesc
34parseDesc :: FilePath -> IO PkgDesc
35parseDesc fp = do
36 unless (takeExtension fp == ".ipkg") $ do
37 putStrLn $ unwords ["The presented iPKG file does not have a '.ipkg' extension:", show fp]
38 exitWith (ExitFailure 1)
39 res <- doesFileExist fp
40 if res
41 then do
42 p <- readFile fp
43 case runparser pPkg defaultPkg fp p of
44 Left err -> fail (show $ PP.plain $ parseErrorDoc err)
45 Right x -> return x
46 else do
47 putStrLn $ unwords [ "The presented iPKG file does not exist:", show fp]
48 exitWith (ExitFailure 1)
50pPkg :: PParser PkgDesc
51pPkg = do
52 reserved "package"
53 p <- pPkgName
54 someSpace
55 modify $ \st -> st { pkgname = p }
56 some pClause
57 st <- get
58 P.eof
59 return st
61pPkgName :: PParser PkgName
62pPkgName = (either fail pure . pkgName =<< packageName) <?> "PkgName"
64-- | Parses a filename.
65-- |
66-- | Treated for now as an identifier or a double-quoted string.
67filename :: Parsing m => m String
68filename = (do
69 -- Treat a double-quoted string as a filename to support spaces.
70 -- This also moves away from tying filenames to identifiers, so
71 -- it will also accept hyphens
72 -- (https://github.com/idris-lang/Idris-dev/issues/2721)
73 filename <- stringLiteral
74 -- Through at least version 0.9.19.1, IPKG executable values were
75 -- possibly namespaced identifiers, like foo.bar.baz.
76 <|> show <$> iName []
77 case filenameErrorMessage filename of
78 Just errorMessage -> fail errorMessage
79 Nothing -> return filename)
80 <?> "filename"
81 where
82 -- TODO: Report failing span better! We could lookAhead,
83 -- or do something with DeltaParsing?
84 filenameErrorMessage :: FilePath -> Maybe String
85 filenameErrorMessage path = either Just (const Nothing) $ do
86 checkEmpty path
87 checkValid path
88 checkNoDirectoryComponent path
89 where
90 checkThat ok message =
91 if ok then Right () else Left message
93 checkEmpty path =
94 checkThat (path /= "") "filename must not be empty"
96 checkValid path =
97 checkThat (System.FilePath.isValid path)
98 "filename must contain only valid characters"
100 checkNoDirectoryComponent path =
101 checkThat (path == takeFileName path)
102 "filename must contain no directory component"
104textUntilEol :: Parsing m => m String
105textUntilEol = many (P.satisfy (not . isEol)) <* eol <* someSpace
107clause :: String -> PParser a -> (PkgDesc -> a -> PkgDesc) -> PParser ()
108clause name p f = do value <- reserved name *> lchar '=' *> p <* someSpace
109 modify $ \st -> f st value
111commaSep :: Parsing m => m a -> m [a]
112commaSep p = P.sepBy1 p (lchar ',')
114pOptions :: PParser [Opt]
115pOptions = do
116 str <- stringLiteral
117 case execArgParserPure (words str) of
118 Opts.Success a -> return a
119 Opts.Failure e -> fail $ fst $ Opts.renderFailure e ""
120 _ -> fail "Unexpected error"
122libIdentifier :: Parsing m => m String
123libIdentifier = identifierWithExtraChars "_'-."
125pClause :: PParser ()
126pClause = clause "executable" filename (\st v -> st { execout = Just v })
127 <|> clause "main" (iName []) (\st v -> st { idris_main = Just v })
128 <|> clause "sourcedir" (identifier <|> stringLiteral) (\st v -> st { sourcedir = v })
129 <|> clause "opts" pOptions (\st v -> st { idris_opts = v ++ idris_opts st })
130 <|> clause "pkgs" (commaSep (pPkgName <* someSpace)) (\st ps ->
131 let pkgs = pureArgParser $ concatMap (\x -> ["-p", show x]) ps
132 in st { pkgdeps = ps `union` pkgdeps st
133 , idris_opts = pkgs ++ idris_opts st })
134 <|> clause "modules" (commaSep moduleName) (\st v -> st { modules = modules st ++ v })
135 <|> clause "libs" (commaSep libIdentifier) (\st v -> st { libdeps = libdeps st ++ v })
136 <|> clause "objs" (commaSep identifier) (\st v -> st { objs = objs st ++ v })
137 <|> clause "makefile" (iName []) (\st v -> st { makefile = Just (show v) })
138 <|> clause "tests" (commaSep (iName [])) (\st v -> st { idris_tests = idris_tests st ++ v })
139 <|> clause "version" textUntilEol (\st v -> st { pkgversion = Just v })
140 <|> clause "readme" textUntilEol (\st v -> st { pkgreadme = Just v })
141 <|> clause "license" textUntilEol (\st v -> st { pkglicense = Just v })
142 <|> clause "homepage" textUntilEol (\st v -> st { pkghomepage = Just v })
143 <|> clause "sourceloc" textUntilEol (\st v -> st { pkgsourceloc = Just v })
144 <|> clause "bugtracker" textUntilEol (\st v -> st { pkgbugtracker = Just v })
145 <|> clause "brief" stringLiteral (\st v -> st { pkgbrief = Just v })
146 <|> clause "author" textUntilEol (\st v -> st { pkgauthor = Just v })
147 <|> clause "maintainer" textUntilEol (\st v -> st { pkgmaintainer = Just v })