module Linear where

import GFC
import AbsGFC
import qualified Abstract as A
import MkGFC (rtQIdent) ----
import Ident
import PrGrammar
import CMacros
import Look
import Str
import Unlex
----import TypeCheck -- to annotate

import Operations
import Zipper

import Monad

-- Linearization for canonical GF. AR 7/6/2003

-- The worker function: linearize a Tree, return
-- a record. Possibly mark subtrees.

-- NB. Constants in trees are annotated by the name of the abstract module.
-- A concrete module name must be given to find (and choose) linearization rules.

linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term
linearizeToRecord gr mk m = lin [] where

  lin ts t = errIn ("lint" +++ prt t) $ ---- 
    if A.isFocusNode (A.nodeTree t) 
      then liftM markFocus $ lint ts t
      else lint ts t

  lint ts t@(Tr (n,xs)) = do

    let binds = A.bindsNode n
        at    = A.atomNode n
    c   <- A.val2cat $ A.valNode n
    xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs

    r <- case at of
      A.AtC f -> look f >>= comp xs'
      A.AtL s -> return $ recS $ tK $ prt at
      A.AtI i -> return $ recS $ tK $ prt at
      A.AtV x -> lookCat c >>= comp [tK (prt at)]
      A.AtM m -> lookCat c >>= comp [tK (prt at)] 

    return $ mk ts $ mkBinds binds r

  look = lookupLin gr . redirectIdent m . rtQIdent
  comp = ccompute gr
  mkBinds bs bdy = case bdy of
    R fs -> R $ [Ass (LV i) (tK (prt t)) | (i,(t,_)) <- zip [0..] bs] ++ fs

  recS t = R [Ass (L (identC "s")) t] ----

  lookCat = return . errVal defLindef . look 
         ---- should always be given in the module

type Marker = [Int] -> Term -> Term

-- if no marking is wanted, use the following

noMark :: [Int] -> Term -> Term
noMark = const id

-- thus the special case:

linearizeNoMark :: CanonGrammar -> Ident -> A.Tree -> Err Term
linearizeNoMark gr = linearizeToRecord gr noMark

-- expand tables in linearized term to full, normal-order tables
-- NB expand from inside-out so that values are not looked up in copies of branches

expandLinTables :: CanonGrammar -> Term -> Err Term
expandLinTables gr t = case t of
  R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs]
  T ty rs -> do
    rs' <- mapPairsM exp [(l,r) | Cas l r <- rs] -- expand from inside-out
    let t' = T ty $ map (uncurry Cas) rs'
    vs  <- alls ty
    ps  <- mapM term2patt vs
    ts' <- mapM (comp . S t') $ vs
    return $ T ty [Cas [p] t | (p,t) <- zip ps ts']
  FV ts -> liftM FV $ mapM exp ts
  _ -> return t
 where
   alls = allParamValues gr
   exp  = expandLinTables gr
   comp = ccompute gr []

-- from records, one can get to records of tables of strings

rec2strTables :: Term -> Err [[(Label,[([Patt],[Str])])]]
rec2strTables r = do
  vs <- allLinValues r
  mapM (mapPairsM (mapPairsM strsFromTerm)) vs

-- from these tables, one may want to extract the ones for the "s" label

strTables2sTables :: [[(Label,[([Patt],[Str])])]] -> [[([Patt],[Str])]]
strTables2sTables ts = [t | r <- ts, (l,t) <- r, l == linLab0]

linLab0 :: Label
linLab0 = L (identC "s")

-- to get lists of token lists is easy
sTables2strs :: [[([Patt],[Str])]] -> [[Str]]
sTables2strs = map snd . concat

-- from this, to get a list of strings --- customize unlexer
strs2strings :: [[Str]] -> [String]
strs2strings = map unlex

-- finally, a top-level function to get a string from an expression
linTree2string :: CanonGrammar -> Ident -> A.Tree -> String
linTree2string gr m e = err id id $ do
  t  <- linearizeNoMark gr m e
  r  <- expandLinTables gr t
  ts <- rec2strTables r
  let ss = strs2strings $ sTables2strs $ strTables2sTables ts
  ifNull (prtBad "empty linearization of" e) (return . head) ss


-- argument is a Tree, value is a list of strs; needed in Parsing

allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str]
allLinsOfTree gr a e = err (singleton . str) id $ do
  e' <- return e ---- annotateExp gr e
  r  <- linearizeNoMark gr a e'
  r' <- expandLinTables gr r
  ts <- rec2strTables r'
  return $ concat $ sTables2strs $ strTables2sTables ts

{-
-- the value is a list of strs
allLinStrings :: CanonGrammar -> Tree -> [Str]
allLinStrings gr ft = case allLinsAsStrs gr ft of
  Ok ts -> map snd $ concat $ map snd $ concat ts
  Bad s -> [str s]

-- the value is a list of strs, not forgetting their arguments
allLinsAsStrs :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Str)])]]
allLinsAsStrs gr ft = do
  lpts <- allLinearizations gr ft
  return $ concat $ mapM (mapPairsM (mapPairsM strsFromTerm)) lpts

-- the value is a list of terms of type Str, not forgetting their arguments
allLinearizations :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Term)])]]
allLinearizations gr ft = linearizeTree gr ft >>= allLinValues

-- to a list of strings
linearizeToStrings :: CanonGrammar -> ([Int] ->Term -> Term) -> Tree -> Err [String]
linearizeToStrings gr mk = liftM (map unlex) . linearizeToStrss gr mk

-- to a list of token lists
linearizeToStrss :: CanonGrammar -> ([Int] -> Term -> Term) -> Tree -> Err [[Str]]
linearizeToStrss gr mk e = do
  R rs <- linearizeToRecord gr mk e ----
  t <- lookupErr linLab0 [(r,s) | Ass r s <- rs]
  return $ map strsFromTerm $ allInTable t 
  

-- the value is a list of strings, not forgetting their arguments
allLinsOfFun :: CanonGrammar -> CIdent -> Err [[(Label,[([Patt],Term)])]]
allLinsOfFun gr f = do
  t <- lookupLin gr f 
  allLinValues t



-}




{- ----
-- returns printname if one exists; otherwise linearizes with metas
printOrLinearize :: CanonGrammar -> Fun -> String
printOrLinearize gr f = 
{- ----
 errVal (prtt f) $ case lookupPrintname cnc f of
  Ok s -> return s
  _ -> -} 
 
          unlines $ take 1 $ err singleton id $ 
       do
    t  <- lookupFunType gr f
    f' <- ref2exp [] t (AC f) --- []
    lin f'
 where 
   lin = linearizeToStrings gr (const id) ----
-}