-- | Commands requiring source grammar in env
module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
import Prelude hiding (putStrLn)
import qualified Prelude as P(putStrLn)
import Data.List(nub,isInfixOf,isPrefixOf)
import qualified Data.ByteString.UTF8 as UTF8(fromString)
import qualified Data.Map as Map

import GF.Infra.SIO(MonadSIO(..),restricted)
import GF.Infra.Option(modifyFlags,optTrace) --,noOptions
import GF.Data.Operations (chunks,err,raise)
import GF.Text.Pretty(render)
import GF.Data.Str(sstr)

import GF.Grammar hiding (Ident,isPrefixOf)
import GF.Grammar.Analyse
import GF.Grammar.Parser (runP, pExp)
import GF.Grammar.ShowTerm
import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
import GF.Infra.Dependencies(depGraph)
import GF.Infra.CheckM(runCheck)

import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
import GF.Command.CommandInfo

class (Monad m,MonadSIO m) => HasGrammar m where
  getGrammar :: m Grammar

sourceCommands :: HasGrammar m => Map.Map String (CommandInfo m)
sourceCommands :: Map String (CommandInfo m)
sourceCommands = [(String, CommandInfo m)] -> Map String (CommandInfo m)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
  (String
"cc", CommandInfo Any
forall (m :: * -> *). CommandInfo m
emptyCommandInfo {
     longname :: String
longname = String
"compute_concrete",
     syntax :: String
syntax = String
"cc (-all | -table | -unqual)? TERM",
     synopsis :: String
synopsis = String
"computes concrete syntax term using a source grammar",
     explanation :: String
explanation = [String] -> String
unlines [
       String
"Compute TERM by concrete syntax definitions. Uses the topmost",
       String
"module (the last one imported) to resolve constant names.",
       String
"N.B.1 You need the flag -retain when importing the grammar, if you want",
       String
"the definitions to be retained after compilation.",
       String
"N.B.2 The resulting term is not a tree in the sense of abstract syntax",
       String
"and hence not a valid input to a Tree-expecting command.",
       String
"This command must be a line of its own, and thus cannot be a part",
       String
"of a pipe."
       ],
     options :: [(String, String)]
options = [
       (String
"all",String
"pick all strings (forms and variants) from records and tables"),
       (String
"list",String
"all strings, comma-separated on one line"),
       (String
"one",String
"pick the first strings, if there is any, from records and tables"),
       (String
"table",String
"show all strings labelled by parameters"),
       (String
"unqual",String
"hide qualifying module names"),
       (String
"trace",String
"trace computations")
       ],
     needsTypeCheck :: Bool
needsTypeCheck = Bool
False, -- why not True?
     exec :: [Option] -> CommandArguments -> m CommandOutput
exec = ([Option] -> [String] -> Grammar -> SIO CommandOutput)
-> [Option] -> CommandArguments -> m CommandOutput
forall (m :: * -> *) t b.
HasGrammar m =>
(t -> [String] -> Grammar -> SIO b) -> t -> CommandArguments -> m b
withStrings [Option] -> [String] -> Grammar -> SIO CommandOutput
forall (m :: * -> *).
Monad m =>
[Option] -> [String] -> Grammar -> m CommandOutput
compute_concrete
     }),
  (String
"dg",  CommandInfo Any
forall (m :: * -> *). CommandInfo m
emptyCommandInfo {
     longname :: String
longname = String
"dependency_graph",
     syntax :: String
syntax = String
"dg (-only=MODULES)?",
     synopsis :: String
synopsis = String
"print module dependency graph",
     explanation :: String
explanation = [String] -> String
unlines [
       String
"Prints the dependency graph of source modules.",
       String
"Requires that import has been done with the -retain flag.",
       String
"The graph is written in the file _gfdepgraph.dot",
       String
"which can be further processed by Graphviz (the system command 'dot').",
       String
"By default, all modules are shown, but the -only flag restricts them",
       String
"by a comma-separated list of patterns, where 'name*' matches modules",
       String
"whose name has prefix 'name', and other patterns match modules with",
       String
"exactly the same name. The graphical conventions are:",
       String
"  solid box = abstract, solid ellipse = concrete, dashed ellipse = other",
       String
"  solid arrow empty head = of, solid arrow = **, dashed arrow = open",
       String
"  dotted arrow = other dependency"
       ],
     flags :: [(String, String)]
flags = [
       (String
"only",String
"list of modules included (default: all), literally or by prefix*")
       ],
     examples :: [(String, String)]
examples = [
       String -> (String, String)
mkEx String
"dg -only=SyntaxEng,Food*  -- shows only SyntaxEng, and those with prefix Food"
       ],
     needsTypeCheck :: Bool
needsTypeCheck = Bool
False,
     exec :: [Option] -> CommandArguments -> m CommandOutput
exec = ([Option] -> [String] -> Grammar -> SIO CommandOutput)
-> [Option] -> CommandArguments -> m CommandOutput
forall (m :: * -> *) t b.
HasGrammar m =>
(t -> [String] -> Grammar -> SIO b) -> t -> CommandArguments -> m b
withStrings [Option] -> [String] -> Grammar -> SIO CommandOutput
forall p. [Option] -> p -> Grammar -> SIO CommandOutput
dependency_graph
     }),
  (String
"sd", CommandInfo Any
forall (m :: * -> *). CommandInfo m
emptyCommandInfo {
     longname :: String
longname = String
"show_dependencies",
     syntax :: String
syntax = String
"sd QUALIFIED_CONSTANT+",
     synopsis :: String
synopsis = String
"show all constants that the given constants depend on",
     explanation :: String
explanation = [String] -> String
unlines [
       String
"Show recursively all qualified constant names, by tracing back the types and definitions",
       String
"of each constant encountered, but just listing every name once.",
       String
"This command requires a source grammar to be in scope, imported with 'import -retain'.",
       String
"Notice that the accuracy is better if the modules are compiled with the flag -optimize=noexpand.",
       String
"This command must be a line of its own, and thus cannot be a part of a pipe."
       ],
     options :: [(String, String)]
options = [
       (String
"size",String
"show the size of the source code for each constants (number of constructors)")
       ],
     examples :: [(String, String)]
examples = [
       String -> (String, String)
mkEx String
"sd ParadigmsEng.mkV ParadigmsEng.mkN  -- show all constants on which mkV and mkN depend",
       String -> (String, String)
mkEx String
"sd -size ParadigmsEng.mkV    -- show all constants on which mkV depends, together with size"
       ],
     needsTypeCheck :: Bool
needsTypeCheck = Bool
False,
     exec :: [Option] -> CommandArguments -> m CommandOutput
exec = ([Option] -> [String] -> Grammar -> SIO CommandOutput)
-> [Option] -> CommandArguments -> m CommandOutput
forall (m :: * -> *) t b.
HasGrammar m =>
(t -> [String] -> Grammar -> SIO b) -> t -> CommandArguments -> m b
withStrings [Option] -> [String] -> Grammar -> SIO CommandOutput
forall (m :: * -> *).
Monad m =>
[Option] -> [String] -> Grammar -> m CommandOutput
show_deps
     }),

  (String
"so", CommandInfo Any
forall (m :: * -> *). CommandInfo m
emptyCommandInfo {
     longname :: String
longname = String
"show_operations",
     syntax :: String
syntax = String
"so (-grep=STRING)* TYPE?",
     synopsis :: String
synopsis = String
"show all operations in scope, possibly restricted to a value type",
     explanation :: String
explanation = [String] -> String
unlines [
       String
"Show the names and type signatures of all operations available in the current resource.",
       String
"This command requires a source grammar to be in scope, imported with 'import -retain'.",
       String
"The operations include the parameter constructors that are in scope.",
       String
"The optional TYPE filters according to the value type.",
       String
"The grep STRINGs filter according to other substrings of the type signatures."{-,
       "This command must be a line of its own, and thus cannot be a part",
       "of a pipe."-}
       ],
     flags :: [(String, String)]
flags = [
       (String
"grep",String
"substring used for filtering (the command can have many of these)")
       ],
     options :: [(String, String)]
options = [
       (String
"raw",String
"show the types in computed forms (instead of category names)")
       ],
     examples :: [(String, String)]
examples = [
         String -> (String, String)
mkEx String
"so Det -- show all opers that create a Det",
         String -> (String, String)
mkEx String
"so -grep=Prep -- find opers relating to Prep",
         String -> (String, String)
mkEx String
"so | wf -file=/tmp/opers -- write the list of opers to a file"
       ],
     needsTypeCheck :: Bool
needsTypeCheck = Bool
False,
     exec :: [Option] -> CommandArguments -> m CommandOutput
exec = ([Option] -> [String] -> Grammar -> SIO CommandOutput)
-> [Option] -> CommandArguments -> m CommandOutput
forall (m :: * -> *) t b.
HasGrammar m =>
(t -> [String] -> Grammar -> SIO b) -> t -> CommandArguments -> m b
withStrings [Option] -> [String] -> Grammar -> SIO CommandOutput
forall (m :: * -> *).
Monad m =>
[Option] -> [String] -> Grammar -> m CommandOutput
show_operations
     }),

  (String
"ss", CommandInfo Any
forall (m :: * -> *). CommandInfo m
emptyCommandInfo {
     longname :: String
longname = String
"show_source",
     syntax :: String
syntax = String
"ss (-strip)? (-save)? MODULE*",
     synopsis :: String
synopsis = String
"show the source code of modules in scope, possibly just headers",
     explanation :: String
explanation = [String] -> String
unlines [
       String
"Show compiled source code, i.e. as it is included in GF object files.",
       String
"This command requires a source grammar to be in scope, imported with 'import -retain'.",
       String
"The optional MODULE arguments cause just these modules to be shown.",
       String
"The -size and -detailedsize options show code size as the number of constructor nodes.",
       String
"This command must be a line of its own, and thus cannot be a part of a pipe."
       ],
     options :: [(String, String)]
options = [
       (String
"detailedsize", String
"instead of code, show the sizes of all judgements and modules"),
       (String
"save", String
"save each MODULE in file MODULE.gfh instead of printing it on terminal"),
       (String
"size", String
"instead of code, show the sizes of all modules"),
       (String
"strip",String
"show only type signatures of oper's and lin's, not their definitions")
       ],
     examples :: [(String, String)]
examples = [
       String -> (String, String)
mkEx String
"ss                         -- print complete current source grammar on terminal",
       String -> (String, String)
mkEx String
"ss -strip -save MorphoFin  -- print the headers in file MorphoFin.gfh"
       ],
     needsTypeCheck :: Bool
needsTypeCheck = Bool
False,
     exec :: [Option] -> CommandArguments -> m CommandOutput
exec = ([Option] -> [String] -> Grammar -> SIO CommandOutput)
-> [Option] -> CommandArguments -> m CommandOutput
forall (m :: * -> *) t b.
HasGrammar m =>
(t -> [String] -> Grammar -> SIO b) -> t -> CommandArguments -> m b
withStrings [Option] -> [String] -> Grammar -> SIO CommandOutput
show_source
     })
  ]
  where
    withStrings :: (t -> [String] -> Grammar -> SIO b) -> t -> CommandArguments -> m b
withStrings t -> [String] -> Grammar -> SIO b
exec t
opts CommandArguments
ts =
      do Grammar
sgr <- m Grammar
forall (m :: * -> *). HasGrammar m => m Grammar
getGrammar
         SIO b -> m b
forall (m :: * -> *) a. MonadSIO m => SIO a -> m a
liftSIO (t -> [String] -> Grammar -> SIO b
exec t
opts (CommandArguments -> [String]
toStrings CommandArguments
ts) Grammar
sgr)

    compute_concrete :: [Option] -> [String] -> Grammar -> m CommandOutput
compute_concrete [Option]
opts [String]
ws Grammar
sgr =
      case P Term -> ByteString -> Either (Posn, String) Term
forall a. P a -> ByteString -> Either (Posn, String) a
runP P Term
pExp (String -> ByteString
UTF8.fromString String
s) of
        Left (Posn
_,String
msg) -> CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandOutput -> m CommandOutput)
-> CommandOutput -> m CommandOutput
forall a b. (a -> b) -> a -> b
$ String -> CommandOutput
pipeMessage String
msg
        Right Term
t      -> CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandOutput -> m CommandOutput)
-> CommandOutput -> m CommandOutput
forall a b. (a -> b) -> a -> b
$ (String -> CommandOutput)
-> (Term -> CommandOutput) -> Err Term -> CommandOutput
forall b a. (String -> b) -> (a -> b) -> Err a -> b
err String -> CommandOutput
pipeMessage
                                     (String -> CommandOutput
fromString (String -> CommandOutput)
-> (Term -> String) -> Term -> CommandOutput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar -> TermPrintStyle -> TermPrintQual -> Term -> String
showTerm Grammar
sgr TermPrintStyle
style TermPrintQual
q)
                                 (Err Term -> CommandOutput) -> Err Term -> CommandOutput
forall a b. (a -> b) -> a -> b
$ [Option] -> Grammar -> Term -> Err Term
forall (m :: * -> *).
(ErrorMonad m, MonadFail m) =>
[Option] -> Grammar -> Term -> m Term
checkComputeTerm [Option]
opts Grammar
sgr Term
t
      where
        (TermPrintStyle
style,TermPrintQual
q) = TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
TermPrintDefault TermPrintQual
Qualified [Option]
opts
        s :: String
s = [String] -> String
unwords [String]
ws

        pOpts :: TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
style TermPrintQual
q []     = (TermPrintStyle
style,TermPrintQual
q)
        pOpts TermPrintStyle
style TermPrintQual
q (Option
o:[Option]
os) =
          case Option
o of
            OOpt String
"table"   -> TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
TermPrintTable   TermPrintQual
q           [Option]
os
            OOpt String
"all"     -> TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
TermPrintAll     TermPrintQual
q           [Option]
os
            OOpt String
"list"    -> TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
TermPrintList    TermPrintQual
q           [Option]
os
            OOpt String
"one"     -> TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
TermPrintOne     TermPrintQual
q           [Option]
os
            OOpt String
"default" -> TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
TermPrintDefault TermPrintQual
q           [Option]
os
            OOpt String
"unqual"  -> TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
style            TermPrintQual
Unqualified [Option]
os
            OOpt String
"qual"    -> TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
style            TermPrintQual
Qualified   [Option]
os
            Option
_              -> TermPrintStyle
-> TermPrintQual -> [Option] -> (TermPrintStyle, TermPrintQual)
pOpts TermPrintStyle
style            TermPrintQual
q           [Option]
os

    show_deps :: [Option] -> [String] -> Grammar -> m CommandOutput
show_deps [Option]
os [String]
xs Grammar
sgr = do
          [Term]
ops <- case [String]
xs of
             String
_:[String]
_ -> do
               let ts :: [Term]
ts = [Term
t | Right Term
t <- (String -> Either (Posn, String) Term)
-> [String] -> [Either (Posn, String) Term]
forall a b. (a -> b) -> [a] -> [b]
map (P Term -> ByteString -> Either (Posn, String) Term
forall a. P a -> ByteString -> Either (Posn, String) a
runP P Term
pExp (ByteString -> Either (Posn, String) Term)
-> (String -> ByteString) -> String -> Either (Posn, String) Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
UTF8.fromString) [String]
xs]
               (String -> m [Term])
-> ([[Term]] -> m [Term]) -> Err [[Term]] -> m [Term]
forall b a. (String -> b) -> (a -> b) -> Err a -> b
err String -> m [Term]
forall a. HasCallStack => String -> a
error ([Term] -> m [Term]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Term] -> m [Term])
-> ([[Term]] -> [Term]) -> [[Term]] -> m [Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term] -> [Term]
forall a. Eq a => [a] -> [a]
nub ([Term] -> [Term]) -> ([[Term]] -> [Term]) -> [[Term]] -> [Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Term]] -> [Term]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (Err [[Term]] -> m [Term]) -> Err [[Term]] -> m [Term]
forall a b. (a -> b) -> a -> b
$ (Term -> Err [Term]) -> [Term] -> Err [[Term]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Grammar -> Term -> Err [Term]
constantDepsTerm Grammar
sgr) [Term]
ts
             [String]
_   -> String -> m [Term]
forall a. HasCallStack => String -> a
error String
"expected one or more qualified constants as argument"
          let prTerm :: Term -> String
prTerm = Grammar -> TermPrintStyle -> TermPrintQual -> Term -> String
showTerm Grammar
sgr TermPrintStyle
TermPrintDefault TermPrintQual
Qualified
          let size :: Term -> Int
size = Grammar -> Term -> Int
sizeConstant Grammar
sgr
          let printed :: String
printed
                | String -> [Option] -> Bool
isOpt String
"size" [Option]
os =
                    let sz :: [Int]
sz = (Term -> Int) -> [Term] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Int
size [Term]
ops in
                    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
"total: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
sz)) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                              [Term -> String
prTerm Term
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
s | (Term
f,Int
s) <- [Term] -> [Int] -> [(Term, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
ops [Int]
sz]
                | Bool
otherwise = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Term -> String) -> [Term] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Term -> String
prTerm [Term]
ops
          CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandOutput -> m CommandOutput)
-> CommandOutput -> m CommandOutput
forall a b. (a -> b) -> a -> b
$ String -> CommandOutput
fromString String
printed

    show_operations :: [Option] -> [String] -> Grammar -> m CommandOutput
show_operations [Option]
os [String]
ts Grammar
sgr =
      case Grammar -> Maybe ModuleName
greatestResource Grammar
sgr of
        Maybe ModuleName
Nothing -> CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandOutput -> m CommandOutput)
-> CommandOutput -> m CommandOutput
forall a b. (a -> b) -> a -> b
$ String -> CommandOutput
fromString String
"no source grammar in scope; did you import with -retain?"
        Just ModuleName
mo -> do
          let greps :: [String]
greps = (Value -> String) -> [Value] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Value -> String
valueString (String -> [Option] -> [Value]
listFlags String
"grep" [Option]
os)
          let isRaw :: Bool
isRaw = String -> [Option] -> Bool
isOpt String
"raw" [Option]
os
          [(QIdent, Term, Location)]
ops <- case [String]
ts of
             String
_:[String]
_ -> do
               let Right Term
t = P Term -> ByteString -> Either (Posn, String) Term
forall a. P a -> ByteString -> Either (Posn, String) a
runP P Term
pExp (String -> ByteString
UTF8.fromString ([String] -> String
unwords [String]
ts))
               Term
ty <- (String -> m Term) -> (Term -> m Term) -> Err Term -> m Term
forall b a. (String -> b) -> (a -> b) -> Err a -> b
err String -> m Term
forall a. HasCallStack => String -> a
error Term -> m Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Err Term -> m Term) -> Err Term -> m Term
forall a b. (a -> b) -> a -> b
$ [Option] -> Grammar -> Term -> Err Term
forall (m :: * -> *).
(ErrorMonad m, MonadFail m) =>
[Option] -> Grammar -> Term -> m Term
checkComputeTerm [Option]
os Grammar
sgr Term
t
               [(QIdent, Term, Location)] -> m [(QIdent, Term, Location)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(QIdent, Term, Location)] -> m [(QIdent, Term, Location)])
-> [(QIdent, Term, Location)] -> m [(QIdent, Term, Location)]
forall a b. (a -> b) -> a -> b
$ Grammar -> Term -> [(QIdent, Term, Location)]
allOpersTo Grammar
sgr Term
ty
             [String]
_   -> [(QIdent, Term, Location)] -> m [(QIdent, Term, Location)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(QIdent, Term, Location)] -> m [(QIdent, Term, Location)])
-> [(QIdent, Term, Location)] -> m [(QIdent, Term, Location)]
forall a b. (a -> b) -> a -> b
$ Grammar -> [(QIdent, Term, Location)]
allOpers Grammar
sgr
          let sigs :: [(Ident, Term)]
sigs = [(Ident
op,Term
ty) | ((ModuleName
mo,Ident
op),Term
ty,Location
pos) <- [(QIdent, Term, Location)]
ops]
          let printer :: Term -> String
printer = if Bool
isRaw
                          then Grammar -> TermPrintStyle -> TermPrintQual -> Term -> String
showTerm Grammar
sgr TermPrintStyle
TermPrintDefault TermPrintQual
Qualified
                          else (Doc -> String
forall a. Pretty a => a -> String
render (Doc -> String) -> (Term -> Doc) -> Term -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Doc
TC.ppType)
          let printed :: [String]
printed = [[String] -> String
unwords [Ident -> String
showIdent Ident
op, String
":", Term -> String
printer Term
ty] | (Ident
op,Term
ty) <- [(Ident, Term)]
sigs]
          CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandOutput -> m CommandOutput)
-> (String -> CommandOutput) -> String -> m CommandOutput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CommandOutput
fromString (String -> m CommandOutput) -> String -> m CommandOutput
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
l | String
l <- [String]
printed, (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
l) [String]
greps]

    show_source :: [Option] -> [String] -> Grammar -> SIO CommandOutput
show_source [Option]
os [String]
ts Grammar
sgr = do
      let strip :: Grammar -> Grammar
strip = if String -> [Option] -> Bool
isOpt String
"strip" [Option]
os then Grammar -> Grammar
stripSourceGrammar else Grammar -> Grammar
forall a. a -> a
id
      let mygr :: Grammar
mygr = Grammar -> Grammar
strip (Grammar -> Grammar) -> Grammar -> Grammar
forall a b. (a -> b) -> a -> b
$ case [String]
ts of
            _:_ -> [Module] -> Grammar
mGrammar [(ModuleName
i,ModuleInfo
m) | (ModuleName
i,ModuleInfo
m) <- Grammar -> [Module]
modules Grammar
sgr, String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
i) [String]
ts]
            [] -> Grammar
sgr
      case () of
        ()
_ | String -> [Option] -> Bool
isOpt String
"detailedsize" [Option]
os ->
               CommandOutput -> SIO CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandOutput -> SIO CommandOutput)
-> (String -> CommandOutput) -> String -> SIO CommandOutput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CommandOutput
fromString (String -> SIO CommandOutput) -> String -> SIO CommandOutput
forall a b. (a -> b) -> a -> b
$ Grammar -> String
printSizesGrammar Grammar
mygr
        ()
_ | String -> [Option] -> Bool
isOpt String
"size" [Option]
os -> do
               let sz :: (Int, [(ModuleName, (Int, [(Ident, Int)]))])
sz = Grammar -> (Int, [(ModuleName, (Int, [(Ident, Int)]))])
sizesGrammar Grammar
mygr
               CommandOutput -> SIO CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandOutput -> SIO CommandOutput)
-> ([String] -> CommandOutput) -> [String] -> SIO CommandOutput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> CommandOutput
fromStrings ([String] -> SIO CommandOutput) -> [String] -> SIO CommandOutput
forall a b. (a -> b) -> a -> b
$
                 (String
"total\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ((Int, [(ModuleName, (Int, [(Ident, Int)]))]) -> Int
forall a b. (a, b) -> a
fst (Int, [(ModuleName, (Int, [(Ident, Int)]))])
sz))String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                 [ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
j String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ((Int, [(Ident, Int)]) -> Int
forall a b. (a, b) -> a
fst (Int, [(Ident, Int)])
k) | (ModuleName
j,(Int, [(Ident, Int)])
k) <- (Int, [(ModuleName, (Int, [(Ident, Int)]))])
-> [(ModuleName, (Int, [(Ident, Int)]))]
forall a b. (a, b) -> b
snd (Int, [(ModuleName, (Int, [(Ident, Int)]))])
sz]
        ()
_ | String -> [Option] -> Bool
isOpt String
"save" [Option]
os ->
              do (Module -> SIO ()) -> [Module] -> SIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Module -> SIO ()
saveModule (Grammar -> [Module]
modules Grammar
mygr)
                 CommandOutput -> SIO CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CommandOutput
void
              where
                saveModule :: Module -> SIO ()
saveModule m :: Module
m@(ModuleName
i,ModuleInfo
_) =
                  let file :: String
file = (ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".gfh")
                  in IO () -> SIO ()
forall a. IO a -> SIO a
restricted (IO () -> SIO ()) -> IO () -> SIO ()
forall a b. (a -> b) -> a -> b
$
                        do String -> String -> IO ()
writeFile String
file (Doc -> String
forall a. Pretty a => a -> String
render (TermPrintQual -> Module -> Doc
ppModule TermPrintQual
Qualified Module
m))
                           String -> IO ()
P.putStrLn (String
"wrote " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file)

        ()
_ -> CommandOutput -> SIO CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandOutput -> SIO CommandOutput)
-> (String -> CommandOutput) -> String -> SIO CommandOutput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CommandOutput
fromString (String -> SIO CommandOutput) -> String -> SIO CommandOutput
forall a b. (a -> b) -> a -> b
$ Grammar -> String
forall a. Pretty a => a -> String
render Grammar
mygr

    dependency_graph :: [Option] -> p -> Grammar -> SIO CommandOutput
dependency_graph [Option]
opts p
ws Grammar
sgr =
      do let stop :: Maybe [String]
stop = case String -> String -> [Option] -> String
valStrOpts String
"only" String
"" [Option]
opts of
                      String
"" -> Maybe [String]
forall a. Maybe a
Nothing
                      String
fs -> [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
chunks Char
',' String
fs
         IO () -> SIO ()
forall a. IO a -> SIO a
restricted (IO () -> SIO ()) -> IO () -> SIO ()
forall a b. (a -> b) -> a -> b
$
            do String -> String -> IO ()
writeFile String
"_gfdepgraph.dot" (Maybe [String] -> Grammar -> String
depGraph Maybe [String]
stop Grammar
sgr)
               String -> IO ()
P.putStrLn String
"wrote graph in file _gfdepgraph.dot"
         CommandOutput -> SIO CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CommandOutput
void

checkComputeTerm :: [Option] -> Grammar -> Term -> m Term
checkComputeTerm [Option]
os Grammar
sgr Term
t =
  do ModuleName
mo <- m ModuleName
-> (ModuleName -> m ModuleName) -> Maybe ModuleName -> m ModuleName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m ModuleName
forall (m :: * -> *) a. ErrorMonad m => String -> m a
raise String
"no source grammar in scope") ModuleName -> m ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModuleName -> m ModuleName)
-> Maybe ModuleName -> m ModuleName
forall a b. (a -> b) -> a -> b
$
           Grammar -> Maybe ModuleName
greatestResource Grammar
sgr
     ((Term
t,Term
_),String
_) <- Check (Term, Term) -> m ((Term, Term), String)
forall (m :: * -> *) a. ErrorMonad m => Check a -> m (a, String)
runCheck (Check (Term, Term) -> m ((Term, Term), String))
-> Check (Term, Term) -> m ((Term, Term), String)
forall a b. (a -> b) -> a -> b
$ do Term
t <- Grammar -> ModuleName -> Term -> Check Term
renameSourceTerm Grammar
sgr ModuleName
mo Term
t
                                Grammar -> Context -> Term -> Check (Term, Term)
inferLType Grammar
sgr [] Term
t
     let opts :: Options
opts = (Flags -> Flags) -> Options
modifyFlags (\Flags
fs->Flags
fs{optTrace :: Bool
optTrace=String -> [Option] -> Bool
isOpt String
"trace" [Option]
os})
         t1 :: Term
t1 = GlobalEnv -> L Ident -> Term -> Term
normalForm (Options -> Grammar -> GlobalEnv
resourceValues Options
opts Grammar
sgr) (Location -> Ident -> L Ident
forall a. Location -> a -> L a
L Location
NoLoc Ident
identW) Term
t
         t2 :: Term
t2 = Term -> Term
evalStr Term
t1
     Term -> m Term
forall (m :: * -> *). MonadFail m => Term -> m Term
checkPredefError Term
t2
  where
    -- ** Try to compute pre{...} tokens in token sequences
    evalStr :: Term -> Term
evalStr Term
t =
      case Term
t of
        C Term
t1 Term
t2 -> (Term -> Term -> Term) -> [Term] -> Term
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Term -> Term -> Term
C ([Term] -> [Term]
evalC [Term
t])
        Term
_ -> (Term -> Term) -> Term -> Term
composSafeOp Term -> Term
evalStr Term
t

    evalC :: [Term] -> [Term]
evalC (C Term
t1 Term
t2:[Term]
ts) = [Term] -> [Term]
evalC (Term
t1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:Term
t2Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
ts)
    evalC (t1 :: Term
t1@(Alts Term
t [(Term, Term)]
tts):[Term]
ts) = case [Term] -> [Term]
evalC [Term]
ts of
                              K String
s:[Term]
ts' -> Term -> [(Term, Term)] -> String -> Term
matchPrefix Term
t [(Term, Term)]
tts String
sTerm -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:String -> Term
K String
sTerm -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
ts'
                              [Term]
ts' -> Term -> Term
evalStr Term
t1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
ts'
    evalC (Term
t:[Term]
ts) = Term -> Term
evalStr Term
tTerm -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term] -> [Term]
evalC [Term]
ts
    evalC [] = []

    matchPrefix :: Term -> [(Term, Term)] -> String -> Term
matchPrefix Term
t0 [(Term, Term)]
tts0 String
s = ((Term, Term) -> Term -> Term) -> Term -> [(Term, Term)] -> Term
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Term, Term) -> Term -> Term
match1 Term
t [(Term, Term)]
tts
      where
        alts :: Term
alts@(Alts Term
t [(Term, Term)]
tts) = Term -> Term
evalStr (Term -> [(Term, Term)] -> Term
Alts Term
t0 [(Term, Term)]
tts0)

        match1 :: (Term, Term) -> Term -> Term
match1 (Term
u,Term
a) Term
r = (String -> Term) -> ([Str] -> Term) -> Err [Str] -> Term
forall b a. (String -> b) -> (a -> b) -> Err a -> b
err (Term -> String -> Term
forall a b. a -> b -> a
const Term
alts) [Str] -> Term
ok (Term -> Err [Str]
strsFromTerm Term
a)
          where ok :: [Str] -> Term
ok [Str]
as = if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s) ((Str -> String) -> [Str] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Str -> String
sstr [Str]
as)
                        then Term
u
                        else Term
r