git.iko.soy/Idris-dev
on fdfcdd3 help sign in
Idris-dev/src/Idris/Package/Parser.hs
248 lines 8.1 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 CPP, ConstraintKinds, FlexibleInstances, TypeSynonymInstances #-}
9module Idris.Package.Parser where
11import Idris.CmdOptions
12import Idris.Imports
13import Idris.Package.Common
14import Idris.Parser.Helpers (HasLastTokenSpan, IdrisInnerParser, MonadicParsing,
15 eol, getLastTokenSpan, iName, identifier, isEol,
16 lchar, multiLineComment, packageName,
17 parseErrorDoc, reserved, runparser,
18 simpleWhiteSpace, singleLineComment)
20import Control.Applicative
21import Control.Monad.State.Strict
22import Data.List (union)
23import System.Directory (doesFileExist)
24import System.Exit
25import System.FilePath (isValid, takeExtension, takeFileName)
26import qualified Text.PrettyPrint.ANSI.Leijen as PP
27import Text.Trifecta ((<?>))
28import qualified Text.Trifecta as P
30type PParser = StateT PkgDesc IdrisInnerParser
32instance HasLastTokenSpan PParser where
33 getLastTokenSpan = return Nothing
35#if MIN_VERSION_base(4,9,0)
36instance {-# OVERLAPPING #-} P.DeltaParsing PParser where
37 line = lift P.line
38 {-# INLINE line #-}
39 position = lift P.position
40 {-# INLINE position #-}
41 slicedWith f (StateT m) = StateT $ \s -> P.slicedWith (\(a,s') b -> (f a b, s')) $ m s
42 {-# INLINE slicedWith #-}
43 rend = lift P.rend
44 {-# INLINE rend #-}
45 restOfLine = lift P.restOfLine
46 {-# INLINE restOfLine #-}
47#endif
49instance {-# OVERLAPPING #-} P.TokenParsing PParser where
50 someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()
53parseDesc :: FilePath -> IO PkgDesc
54parseDesc fp = do
55 when (not $ takeExtension fp == ".ipkg") $ do
56 putStrLn $ unwords ["The presented iPKG file does not have a '.ipkg' extension:", show fp]
57 exitWith (ExitFailure 1)
58 res <- doesFileExist fp
59 if res
60 then do
61 p <- readFile fp
62 case runparser pPkg defaultPkg fp p of
63 Left err -> fail (show $ PP.plain $ parseErrorDoc err)
64 Right x -> return x
65 else do
66 putStrLn $ unwords [ "The presented iPKG file does not exist:", show fp]
67 exitWith (ExitFailure 1)
69pPkg :: PParser PkgDesc
70pPkg = do
71 reserved "package"
72 p <- pPkgName
73 P.someSpace
74 st <- get
75 put (st { pkgname = p })
76 some pClause
77 st <- get
78 P.eof
79 return st
81pPkgName :: PParser PkgName
82pPkgName = (either fail pure . pkgName =<< packageName) <?> "PkgName"
84-- | Parses a filename.
85-- |
86-- | Treated for now as an identifier or a double-quoted string.
87filename :: (MonadicParsing m, HasLastTokenSpan m) => m String
88filename = (do
89 filename <- P.token $
90 -- Treat a double-quoted string as a filename to support spaces.
91 -- This also moves away from tying filenames to identifiers, so
92 -- it will also accept hyphens
93 -- (https://github.com/idris-lang/Idris-dev/issues/2721)
94 P.stringLiteral
95 <|>
96 -- Through at least version 0.9.19.1, IPKG executable values were
97 -- possibly namespaced identifiers, like foo.bar.baz.
98 show <$> fst <$> iName []
99 case filenameErrorMessage filename of
100 Just errorMessage -> fail errorMessage
101 Nothing -> return filename)
102 <?> "filename"
103 where
104 -- TODO: Report failing span better! We could lookAhead,
105 -- or do something with DeltaParsing?
106 filenameErrorMessage :: FilePath -> Maybe String
107 filenameErrorMessage path = either Just (const Nothing) $ do
108 checkEmpty path
109 checkValid path
110 checkNoDirectoryComponent path
111 where
112 checkThat ok message =
113 if ok then Right () else Left message
115 checkEmpty path =
116 checkThat (path /= "") "filename must not be empty"
118 checkValid path =
119 checkThat (System.FilePath.isValid path)
120 "filename must contain only valid characters"
122 checkNoDirectoryComponent path =
123 checkThat (path == takeFileName path)
124 "filename must contain no directory component"
127pClause :: PParser ()
128pClause = do reserved "executable"; lchar '=';
129 exec <- filename
130 st <- get
131 put (st { execout = Just exec })
133 <|> do reserved "main"; lchar '=';
134 main <- fst <$> iName []
135 st <- get
136 put (st { idris_main = Just main })
138 <|> do reserved "sourcedir"; lchar '=';
139 src <- fst <$> identifier
140 st <- get
141 put (st { sourcedir = src })
143 <|> do reserved "opts"; lchar '=';
144 opts <- P.stringLiteral
145 st <- get
146 let args = pureArgParser (words opts)
147 put (st { idris_opts = args ++ idris_opts st })
149 <|> do reserved "pkgs"; lchar '=';
150 ps <- P.sepBy1 (pPkgName <* P.someSpace) (lchar ',')
151 st <- get
152 let pkgs = pureArgParser $ concatMap (\x -> ["-p", show x]) ps
154 put (st { pkgdeps = ps `union` (pkgdeps st)
155 , idris_opts = pkgs ++ idris_opts st})
157 <|> do reserved "modules"; lchar '=';
158 ms <- P.sepBy1 (fst <$> iName []) (lchar ',')
159 st <- get
160 put (st { modules = modules st ++ ms })
162 <|> do reserved "libs"; lchar '=';
163 ls <- P.sepBy1 (fst <$> identifier) (lchar ',')
164 st <- get
165 put (st { libdeps = libdeps st ++ ls })
167 <|> do reserved "objs"; lchar '=';
168 ls <- P.sepBy1 (fst <$> identifier) (lchar ',')
169 st <- get
170 put (st { objs = objs st ++ ls })
172 <|> do reserved "makefile"; lchar '=';
173 mk <- fst <$> iName []
174 st <- get
175 put (st { makefile = Just (show mk) })
177 <|> do reserved "tests"; lchar '=';
178 ts <- P.sepBy1 (fst <$> iName []) (lchar ',')
179 st <- get
180 put st { idris_tests = idris_tests st ++ ts }
182 <|> do reserved "version"
183 lchar '='
184 vStr <- many (P.satisfy (not . isEol))
185 eol
186 P.someSpace
187 st <- get
188 put st {pkgversion = Just vStr}
190 <|> do reserved "readme"
191 lchar '='
192 rme <- many (P.satisfy (not . isEol))
193 eol
194 P.someSpace
195 st <- get
196 put (st { pkgreadme = Just rme })
198 <|> do reserved "license"
199 lchar '='
200 lStr <- many (P.satisfy (not . isEol))
201 eol
202 st <- get
203 put st {pkglicense = Just lStr}
205 <|> do reserved "homepage"
206 lchar '='
207 www <- many (P.satisfy (not . isEol))
208 eol
209 P.someSpace
210 st <- get
211 put st {pkghomepage = Just www}
213 <|> do reserved "sourceloc"
214 lchar '='
215 srcpage <- many (P.satisfy (not . isEol))
216 eol
217 P.someSpace
218 st <- get
219 put st {pkgsourceloc = Just srcpage}
221 <|> do reserved "bugtracker"
222 lchar '='
223 src <- many (P.satisfy (not . isEol))
224 eol
225 P.someSpace
226 st <- get
227 put st {pkgbugtracker = Just src}
229 <|> do reserved "brief"
230 lchar '='
231 brief <- P.stringLiteral
232 st <- get
233 P.someSpace
234 put st {pkgbrief = Just brief}
236 <|> do reserved "author"; lchar '=';
237 author <- many (P.satisfy (not . isEol))
238 eol
239 P.someSpace
240 st <- get
241 put st {pkgauthor = Just author}
243 <|> do reserved "maintainer"; lchar '=';
244 maintainer <- many (P.satisfy (not . isEol))
245 eol
246 P.someSpace
247 st <- get
248 put st {pkgmaintainer = Just maintainer}