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