mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
155 lines
4.8 KiB
Haskell
155 lines
4.8 KiB
Haskell
module GF.Command.Parse(readCommandLine, readTransactionCommand, pCommand) where
|
|
|
|
import PGF(pExpr,pIdent)
|
|
import PGF2(BindType(..),readType,readContext)
|
|
import GF.Infra.Ident(identS)
|
|
import GF.Grammar.Grammar(Term(Abs))
|
|
import GF.Grammar.Parser(runPartial,pTerm)
|
|
import GF.Command.Abstract
|
|
|
|
import Data.Char(isDigit,isSpace)
|
|
import Control.Monad(liftM2)
|
|
import Text.ParserCombinators.ReadP
|
|
|
|
readCommandLine :: String -> Maybe CommandLine
|
|
readCommandLine s =
|
|
case [x | (x,cs) <- readP_to_S pCommandLine s, all isSpace cs] of
|
|
[x] -> Just x
|
|
_ -> Nothing
|
|
|
|
pCommandLine =
|
|
(skipSpaces >> char '-' >> char '-' >> pTheRest >> return []) -- comment
|
|
<++
|
|
(sepBy (skipSpaces >> pPipe) (skipSpaces >> char ';'))
|
|
|
|
pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
|
|
|
|
pCommand = (do
|
|
cmd <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
|
|
skipSpaces
|
|
opts <- sepBy pOption skipSpaces
|
|
arg <- if getCommandOp cmd `elem` ["cc","sd","so"] then pArgTerm else pArgument
|
|
return (Command cmd opts arg)
|
|
)
|
|
<++ (do
|
|
char '?'
|
|
skipSpaces
|
|
c <- pSystemCommand
|
|
return (Command "sp" [OFlag "command" (LStr c)] ANoArg)
|
|
)
|
|
|
|
readTransactionCommand :: String -> Maybe TransactionCommand
|
|
readTransactionCommand s =
|
|
case [x | (x,cs) <- readP_to_S pTransactionCommand s, all isSpace cs] of
|
|
[x] -> Just x
|
|
_ -> Nothing
|
|
|
|
pTransactionCommand = do
|
|
skipSpaces
|
|
cmd <- pIdent
|
|
skipSpaces
|
|
opts <- sepBy pOption skipSpaces
|
|
skipSpaces
|
|
kwd <- pIdent
|
|
skipSpaces
|
|
case kwd of
|
|
"fun" | take 1 cmd == "c" -> do
|
|
f <- pIdent
|
|
skipSpaces
|
|
char ':'
|
|
skipSpaces
|
|
ty <- readS_to_P (\s -> case readType s of
|
|
Just ty -> [(ty,"")]
|
|
Nothing -> [])
|
|
return (CreateFun opts f ty)
|
|
| take 1 cmd == "d" -> do
|
|
f <- pIdent
|
|
return (DropFun opts f)
|
|
"cat" | take 1 cmd == "c" -> do
|
|
c <- pIdent
|
|
skipSpaces
|
|
ctxt <- readS_to_P (\s -> case readContext s of
|
|
Just ty -> [(ty,"")]
|
|
Nothing -> [])
|
|
return (CreateCat opts c ctxt)
|
|
| take 1 cmd == "d" -> do
|
|
c <- pIdent
|
|
return (DropCat opts c)
|
|
"concrete"
|
|
| take 1 cmd == "c" -> do
|
|
name <- pIdent
|
|
return (CreateConcrete opts name)
|
|
| take 1 cmd == "d" -> do
|
|
name <- pIdent
|
|
return (DropConcrete opts name)
|
|
"lin" | elem (take 1 cmd) ["c","a"] -> do
|
|
f <- pIdent
|
|
body <- option Nothing $ do
|
|
skipSpaces
|
|
args <- sepBy pIdent skipSpaces
|
|
skipSpaces
|
|
char '='
|
|
skipSpaces
|
|
t <- readS_to_P (\s -> case runPartial pTerm s of
|
|
Right (s,t) -> [(t,s)]
|
|
_ -> [])
|
|
return (Just (foldr (Abs Explicit . identS) t args))
|
|
return (CreateLin opts f body (take 1 cmd == "a"))
|
|
| take 1 cmd == "d" -> do
|
|
f <- pIdent
|
|
return (DropLin opts f)
|
|
"lincat"
|
|
| take 1 cmd == "c" -> do
|
|
f <- pIdent
|
|
body <- option Nothing $ do
|
|
skipSpaces
|
|
char '='
|
|
skipSpaces
|
|
t <- readS_to_P (\s -> case runPartial pTerm s of
|
|
Right (s,t) -> [(t,s)]
|
|
_ -> [])
|
|
return (Just t)
|
|
return (CreateLincat opts f body)
|
|
| take 1 cmd == "d" -> do
|
|
f <- pIdent
|
|
return (DropLincat opts f)
|
|
_ -> pfail
|
|
|
|
pOption = do
|
|
char '-'
|
|
flg <- pIdent
|
|
option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
|
|
|
|
pValue = do
|
|
fmap LInt (readS_to_P reads)
|
|
<++
|
|
fmap LFlt (readS_to_P reads)
|
|
<++
|
|
fmap LStr (readS_to_P reads)
|
|
<++
|
|
fmap LStr pFilename
|
|
|
|
pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
|
|
isFileFirst c = not (isSpace c) && not (isDigit c)
|
|
|
|
pArgument =
|
|
option ANoArg
|
|
(fmap AExpr pExpr
|
|
<++
|
|
(skipSpaces >> char '%' >> fmap AMacro pIdent))
|
|
|
|
pArgTerm = ATerm `fmap` readS_to_P sTerm
|
|
where
|
|
sTerm s = case runPartial pTerm s of
|
|
Right (s,t) -> [(t,s)]
|
|
_ -> []
|
|
|
|
pSystemCommand =
|
|
(char '"' >> (manyTill (pEsc <++ get) (char '"')))
|
|
<++
|
|
pTheRest
|
|
where
|
|
pEsc = char '\\' >> get
|
|
|
|
pTheRest = munch (const True)
|