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