module Commands where

import Operations
import Zipper

----import AccessGrammar (Term (Vr)) ----
import qualified Grammar as G ---- Cat
import GFC
import qualified AbsGFC ---- Atom
import CMacros
import LookAbs

import GetTree
import API
import ShellState

import qualified Shell
import qualified Ident as I
import qualified PShell
import qualified Macros as M
import PrGrammar
import TypeCheck ---- tree2exp
import PGrammar
import IOGrammar
import UseIO
import Unicode

import Option
import CF
----- import CFIdent (cat2CFCat, cfCat2Cat)
import Linear
import Randomized
import Editing
import Session
import Custom

import Random (mkStdGen)
import Monad (liftM2)
import List (intersperse)
import Random (newStdGen)

--- temporary hacks for GF 2.0

-- abstract command language for syntax editing. AR 22/8/2001

data Command =
   CNewCat G.Cat
 | CNewTree String
 | CAhead Int
 | CBack Int
 | CNextMeta
 | CPrevMeta
 | CTop
 | CLast
 | CRefineWithTree String
 | CRefineWithAtom String
 | CRefineParse String
 | CWrapWithFun (G.Fun,Int)
 | CChangeHead G.Fun
 | CPeelHead
 | CAlphaConvert String
 | CRefineRandom
 | CSelectCand Int
 | CTermCommand  String
 | CAddOption Option
 | CRemoveOption Option
 | CDelete
 | CUndo
 | CView
 | CMenu
 | CQuit
 | CHelp  (CEnv -> String) -- help message depends on grammar and interface
 | CError -- syntax error in command
 | CVoid  -- empty command, e.g. just <enter>

-- commands affecting CEnv
 | CCEnvImport String
 | CCEnvEmptyAndImport String
 | CCEnvOpenTerm String
 | CCEnvOpenString String
 | CCEnvEmpty

 | CCEnvOn  String
 | CCEnvOff String

 | CCEnvGFShell String

-- other commands using IO
 | CCEnvRefineWithTree String
 | CCEnvRefineParse String

isQuit CQuit = True
isQuit _ = False

-- an abstract environment type

type CEnv    = ShellState

grammarCEnv  = firstStateGrammar
canCEnv  = canModules
concreteCEnv = cncId
abstractCEnv = absId

stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) ---

initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of
----  Just cat -> action2commandNext (newCat gr (identC cat)) initSState
  _ -> initSState
 where 
   sgr = firstStateGrammar env
   gr  = stateGrammarST sgr

-- the main function

execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState)
execCommand env c s = case c of
{- ----
-- these commands do need IO
  CCEnvImport file -> do

    gr <- optFile2grammar noOptions (maybeStateAbstract env) file
    let lan = getLangNameOpt noOptions file
    return (updateLanguage file (lan, getStateConcrete gr) 
                           (initWithAbstract (stateAbstract gr) env), s)

  CCEnvEmptyAndImport file -> do
    gr <- optFile2grammar noOptions Nothing file
    let lan = getLangNameOpt noOptions file
    return (updateLanguage file (lan, getStateConcrete gr) 
                 (initWithAbstract (stateAbstract gr) emptyShellState), initSState)

  CCEnvEmpty -> do
    return (emptyShellState, initSState)

  CCEnvGFShell command -> do
    let cs = PShell.pCommandLines command
    (msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env)
    return (env', changeMsg msg s) ----

  CCEnvOpenTerm file -> do
    c <- readFileIf file
    let (fs,t) = envAndTerm file c

    env' <- shellStateFromFiles noOptions fs
    return (env', (action2commandNext $ \x -> 
                      (string2treeErr (grammarCEnv env') t x >>= 
                                                      \t -> newTree t x)) s)

  CCEnvOpenString file -> do
    c <- readFileIf file
    let (fs,t) = envAndTerm file c
    env' <- shellStateFromFiles noOptions fs
    let gr   = grammarCEnv env'
        sgr  = firstStateGrammar env'
        agrs = allActiveGrammars env'
        cat  = firstCatOpts (stateOptions sgr) sgr
    state0 <- err (const $ return (stateSState s)) return $
                   newCat gr (cfCat2Cat cat) $ stateSState s
    state1 <- return $ 
                   refineByExps True gr (parseAny agrs cat t) $ changeState state0 s
    return (env', state1)

  CCEnvOn  name -> return (languageOn  (language name) env,s)
  CCEnvOff name -> return (languageOff (language name) env,s)
-}
-- this command is improved by the use of IO
  CRefineRandom -> do
    g <- newStdGen
    return (env, action2commandNext (refineRandom g 41 cgr) s)

-- these commands use IO
  CCEnvRefineWithTree file -> do
    str <- readFileIf file 
    execCommand env (CRefineWithTree str) s 
  CCEnvRefineParse file -> do
    str <- readFileIf file 
    execCommand env (CRefineParse str) s 

-- other commands don't need IO; they are available in the fudget
  c -> return (env, execECommand env c s)

 where
   gr = grammarCEnv env
   cgr = canCEnv env
   opts = globalOptions env

   -- format for documents: import lines of form "-- file", then term 
   envAndTerm f s = 
     (map ((initFilePath f ++) . filter (/=' ') . drop 2) fs, unlines ss) where
       (fs,ss) = span isImport (lines s)
       isImport l = take 2 l == "--"


execECommand :: CEnv -> Command -> ECommand
execECommand env c = case c of
  CNewCat cat        -> action2commandNext $ \x -> do
                          s' <- newCat cgr cat x
                          uniqueRefinements cgr s'
{- ----
  CNewTree s         -> action2commandNext $ \x -> do 
                          t  <- string2treeErr gr s 
                          s' <- newTree t x
                          uniqueRefinements cgr s'
-}
  CAhead n           -> action2command (goAheadN n)
  CBack n            -> action2command (goBackN n)
  CTop               -> action2command $ return . goRoot
  CLast              -> action2command $ goLast
  CNextMeta          -> action2command goNextNewMeta
  CPrevMeta          -> action2command goPrevNewMeta
  CRefineWithAtom s  -> action2commandNext $ \x -> do 
                          t  <- string2ref gr s
                          s' <- refineWithAtom der cgr t x
                          uniqueRefinements cgr s'
  CWrapWithFun fi    -> action2commandNext $ wrapWithFun cgr fi
  CChangeHead f      -> action2commandNext $ changeFunHead cgr f
  CPeelHead          -> action2commandNext $ peelFunHead cgr
{- ----
  CAlphaConvert s    -> action2commandNext $ \x ->
                          string2varPair s >>= \xy -> alphaConvert gr xy x

  CRefineWithTree s  -> action2commandNext $ \x -> 
                          (string2treeErr gr s x >>= \t -> refineWithTree der gr t x)

  CRefineParse str   -> \s -> refineByExps der gr 
                          (parseAny agrs (cat2CFCat (actCat (stateSState s))) str) s
-}
  
  CRefineRandom -> \s -> action2commandNext
                              (refineRandom (stdGenCEnv env s) 41 cgr) s 

  CSelectCand i      -> selectCand cgr i
{- ----
  CTermCommand c     -> case c of
                          "paraphrase" -> \s ->
                             replaceByTermCommand gr c (actExp (stateSState s)) s
                          "transfer" -> action2commandNext $
                                        transferSubTree (stateTransferFun sgr) gr
                          _ -> replaceByEditCommand gr c
-}
----  CAddOption o       -> changeStOptions (addOption o)
----  CRemoveOption o    -> changeStOptions (removeOption o)
  CDelete            -> action2commandNext $ deleteSubTree cgr
  CUndo              -> undoCommand
----  CMenu              -> \s -> changeMsg (menuState env s) s
  CView              -> changeView
  CHelp h            -> changeMsg [h env]
  CVoid              -> id
  _                  -> changeMsg ["command not yet implemented"]
 where
   sgr  = firstStateGrammar env 
   agrs = [sgr] ---- allActiveGrammars env
   cgr  = canCEnv env
   gr   = grammarCEnv env
   der  = maybe True not $ caseYesNo (globalOptions env) noDepTypes
          -- if there are dep types, then derived refs;  deptypes is the default

--


{- ----
string2varPair :: String -> Err (I.Ident,I.Ident)
string2varPair s = case words s of
  x : y : [] -> liftM2 (,) (string2ident x) (string2ident y)
  _          -> Bad "expected format 'x y'"


-- seen on display

cMenuDisplay :: String -> Command
cMenuDisplay s = CAddOption (menuDisplay s)
-}
newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) | 
                         (c,[]) <- allCatsOf (canCEnv env)]

mkRefineMenu :: CEnv -> SState -> [(Command,String)]
mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate]

mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))]
mkRefineMenuAll env sstate = 
  case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of
    ([],[],wraps) -> 
       [(CWrapWithFun fi, prWrap fit)     | fit@(fi,_) <- wraps] ++
       [(CChangeHead f,   prChangeHead f) | f <- headChangesState cgr state] ++
       [(CPeelHead,     (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++
       [(CDelete,       (ifShort "d"  "Delete",   "d"))]
    (refs,[],_)   -> [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs]
    (_,cands,_)   -> [(CSelectCand i,   prCand (t,i))    | (t,i) <- zip cands [0..]]

 where
  prRef  (f,t) = 
    (ifShort "r" "Refine" +++ prOrLinExp f +++ ifTyped (":" +++ prt t),
     "r" +++ prRefinement f)
  prChangeHead f = 
    (ifShort "ch" "ChangeHead" +++ prOrLinFun f,
     "ch" +++ prQIdent f)
  prWrap ((f,i),t) = 
    (ifShort "w" "Wrap"   +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++
     ifShort (show i) (prBracket (show i)),
     "w" +++ prQIdent f +++ show i)
  prCand (t,i) = 
    (ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i)

  gr = grammarCEnv env
  cgr = canCEnv env
  state = stateSState sstate
  opts = addOptions (optsSState sstate) (globalOptions env)
  ifOpt f v a b = case getOptVal opts f of 
    Just s | s == v -> a 
    _ -> b
  ifShort = ifOpt sizeDisplay "short"
  ifTyped t = ifOpt typeDisplay "typed" t ""
  prOrLinExp t = prRefinement t --- maybe (prt t) prOrLinFun $ M.justIdentOf t
  prOrLinTree t = case getOptVal opts menuDisplay of
    Just "Abs" -> prt t
    Just lang -> optLinearizeTreeVal (addOption firstLin opts) 
                          (stateGrammarOfLang env (language lang)) t
    _ -> prt t
  prOrLinFun = printname env sstate

-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped
-- the default is Abs, long, untyped; the Menus menu changes the parameter

emptyMenuItem = (CVoid,("",""))



---- allStringCommands = snd $ customInfo customStringCommand
termCommandMenu, stringCommandMenu :: [(Command,String)]
termCommandMenu = []
stringCommandMenu = []

displayCommandMenu :: CEnv -> [(Command,String)]
displayCommandMenu env = []
{- ----
---- allTermCommands = snd $ customInfo customEditCommand
termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands]

stringCommandMenu = 
   (CAddOption showStruct,      "structured") :
   (CRemoveOption showStruct,   "unstructured") :
  [(CAddOption (filterString s), s) | s <- allStringCommands]

displayCommandMenu env = 
  [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++
  [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++
  [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]]
 where
   langs = map prLanguage $ allLanguages env

changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command
changeMenuLanguage s = CAddOption (menuDisplay s)
changeMenuSize s     = CAddOption (sizeDisplay s)
changeMenuTyped s    = CAddOption (typeDisplay s)
-}

menuState env = map snd . mkRefineMenu env

prState :: State -> [String]
prState s = prMarkedTree (loc2treeMarked s)

displayJustStateIn env state = case displaySStateIn env state of 
   (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF

displaySStateIn env state = (tree',msg,menu) where
  (tree,msg,menu) = displaySState env state
  grs    = allStateGrammars env
  lang   = (viewSState state) `mod` (length grs + 3)
  tree'  = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang
  opts   = addOptions (optsSState state) (globalOptions env)  -- state opts override
  lin g  = linearizeState fudWrap opts g zipper
  exp    = return $ tree2string $ loc2tree zipper
  zipper = stateSState state
  linAll = map lin grs
  separ  = singleton . map unlines . intersperse [replicate 72 '*']

displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
  tagXML "linearizations" (concat 
    [tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]),
  tagXML "tree"           tree,
  tagXML "message"        msg,
  tagXML "menu"           (tagsXML "item" menu')
  ]
 where
  (tree,msg,menu) = displaySState env state
  menu'  = [tagXML "show" [s] ++ tagXML "send" [c] | (s,c) <- menu] 
  (ls,grs) = unzip $ lgrs
  lgrs   = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env
  lins   = (langAbstract, exp) : linAll
  opts   = addOptions (optsSState state) (globalOptions env)  -- state opts override
  lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where
                  uni = optEncodeUTF8 n gr . mkUnicode
  exp    = prprTree $ loc2tree zipper
---  xml    = prExpXML gr $ tree2exp $ loc2tree zipper --- better: dir. from zipper
  zipper = stateSState state
  linAll = map lin lgrs
  gr     = firstStateGrammar env

langAbstract = language "Abstract"
langXML      = language "XML"


linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String]
linearizeState wrap opts gr = 
 wrap . strop . unt . optLinearizeTreeVal opts gr . loc2tree
                  --- markedLinString br g
  where
   unt   = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g
   strop = id ---- maybe id ($ g) $ customAsOptVal opts filterString customStringCommand
   br    = oElem showStruct opts

noWrap, fudWrap :: String -> [String]
noWrap = lines
fudWrap = lines . wrapLines 0 ---

displaySState :: CEnv -> SState -> ([String],[String],[(String,String)])
displaySState env state = 
  (prState (stateSState state), msgSState state, menuSState env state)

menuSState :: CEnv -> SState -> [(String,String)]
menuSState env state = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state]

printname :: CEnv -> SState -> G.Fun -> String
printname env state f = case getOptVal opts menuDisplay of
  Just "Abs" -> prQIdent f
----  Just lang  -> printn lang f
  _ -> prQIdent f
 where
  opts = addOptions (optsSState state) (globalOptions env)
  printn lang = linearize gr ---- printOrLinearize (grammarOfLang env (language lang))
  gr = grammarCEnv env


--- XML printing; does not belong here!

tagsXML t = concatMap (tagXML t)
tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t]
tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t]
mkTagXML t = '<':t ++ ">"
mkEndTagXML t = mkTagXML ('/':t)
mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">"
mkTagAttrXML  t av  = mkTagAttrsXML t [av]