-- | 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.Dependencies(depGraph)
import GF.Infra.CheckM
import GF.Text.Pretty(render,pp)
import GF.Data.Str(sstr)
import GF.Data.Operations (chunks,err,raise)

import GF.Grammar hiding (Ident,isPrefixOf)
import GF.Grammar.Analyse
import GF.Grammar.ShowTerm
import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute(normalForm,normalFlatForm,Globals(..),stdPredef)
import GF.Compile.TypeCheck as TC(inferLType)

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

  ("so", emptyCommandInfo {
     longname = "show_operations",
     syntax = "so (-grep=STRING)* TYPE?",
     synopsis = "show all operations in scope, possibly restricted to a value type",
     explanation = unlines [
       "Show the names and type signatures of all operations available in the current resource.",
       "If no grammar is loaded with 'import -retain' or 'import -resource',",
       "then only the predefined operations are in scope.",
       "The operations include also the parameter constructors that are in scope.",
       "The optional TYPE filters according to the value type.",
       "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 = [
       ("grep","substring used for filtering (the command can have many of these)")
       ],
     options = [
       ("raw","show the types in computed forms (instead of category names)")
       ],
     examples = [
         mkEx "so Det -- show all opers that create a Det",
         mkEx "so -grep=Prep -- find opers relating to Prep",
         mkEx "so | wf -file=/tmp/opers -- write the list of opers to a file"
       ],
     needsTypeCheck = False,
     exec = withTerm show_operations
     }),

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

    withTerm exec opts ts =
      do sgr <- getGrammar
         liftSIO (exec opts (toTerm ts) sgr)

    compute_concrete opts t sgr = fmap fst $ runCheck $ do
      ts <- checkComputeTerm opts sgr t
      return (fromStrings (map (showTerm sgr style q) ts))
      where
        (style,q) = pOpts TermPrintDefault Qualified opts

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

    show_deps os t sgr = do
          ops <- err error (return . nub) $ constantDepsTerm sgr t
          let prTerm = showTerm sgr TermPrintDefault Qualified
          let size = sizeConstant sgr
          let printed
                | isOpt "size" os =
                    let sz = map size ops in
                    unlines $ ("total: " ++ show (sum sz)) :
                              [prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz]
                | otherwise = unwords $ map prTerm ops
          return $ fromString printed

    show_operations os t sgr = fmap fst $ runCheck $ do
      let greps = map valueString (listFlags "grep" os)
      ops <- do tys <- checkComputeTerm os sgr t
                return $ concatMap (allOpersTo sgr) tys
      let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
          printer = showTerm sgr TermPrintDefault
                             (if isOpt "raw" os then Qualified else Unqualified)
          printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
      return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]

    show_source os ts sgr = do
      let strip = if isOpt "strip" os then stripSourceGrammar else id
      let mygr = strip $ case ts of
            _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (render i) ts]
            [] -> sgr
      case () of
        _ | isOpt "detailedsize" os ->
               return . fromString $ printSizesGrammar mygr
        _ | isOpt "size" os -> do
               let sz = sizesGrammar mygr
               return . fromStrings $
                 ("total\t" ++ show (fst sz)):
                 [render j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
        _ | isOpt "save" os ->
              do mapM_ saveModule (modules mygr)
                 return void
              where
                saveModule m@(i,_) =
                  let file = (render i ++ ".gfh")
                  in restricted $
                        do writeFile file (render (ppModule Qualified m))
                           P.putStrLn ("wrote " ++ file)

        _ -> return . fromString $ render mygr

    dependency_graph opts ws sgr =
      do let stop = case valStrOpts "only" "" opts of
                      "" -> Nothing
                      fs -> Just $ chunks ',' fs
         restricted $
            do writeFile "_gfdepgraph.dot" (depGraph stop sgr)
               P.putStrLn "wrote graph in file _gfdepgraph.dot"
         return void

checkComputeTerm os sgr t =
  do mo <- case greatestResource sgr of
             Nothing -> checkError (pp "No source grammar in scope")
             Just mo -> return mo
     t <- renameSourceTerm sgr mo t
     (t,_) <- inferLType g t
     if isOpt "flat" os
       then fmap (map evalStr) (normalFlatForm g t)
       else fmap (singleton . evalStr) (normalForm g t)
  where
    -- ** Try to compute pre{...} tokens in token sequences
    singleton x = [x]

    g = Gl sgr (stdPredef g) False

    evalStr t =
      case t of
        C t1 t2 -> foldr1 C (evalC [t])
        _ -> composSafeOp evalStr t

    evalC (C t1 t2:ts) = evalC (t1:t2:ts)
    evalC (t1@(Alts t tts):ts) = case evalC ts of
                              K s:ts' -> matchPrefix t tts s:K s:ts'
                              ts' -> evalStr t1:ts'
    evalC (t:ts) = evalStr t:evalC ts
    evalC [] = []

    matchPrefix t0 tts0 s = foldr match1 t tts
      where
        alts@(Alts t tts) = evalStr (Alts t0 tts0)

        match1 (u,a) r = err (const alts) ok (strsFromTerm a)
          where ok as = if any (`isPrefixOf` s) (map sstr as)
                        then u
                        else r
