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