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