content: {-# LANGUAGE BangPatterns, FlexibleContexts #-}
  module GF.Compile.GrammarToPGF (mkCanon2pgf) where
  
  --import GF.Compile.Export
  import GF.Compile.GeneratePMCFG
  import GF.Compile.GenerateBC
  
  import PGF(CId,mkCId,utf8CId)
  import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
  import PGF.Internal(updateProductionIndices)
  --import qualified PGF.Macros as CM
  import qualified PGF.Internal as C
  import qualified PGF.Internal as D
  import GF.Grammar.Predef
  --import GF.Grammar.Printer
  import GF.Grammar.Grammar
  import qualified GF.Grammar.Lookup as Look
  import qualified GF.Grammar as A
  import qualified GF.Grammar.Macros as GM
  --import GF.Compile.GeneratePMCFG
  
  import GF.Infra.Ident
  import GF.Infra.Option
  import GF.Infra.UseIO (IOE)
  import GF.Data.Operations
  
  import Data.List
  import qualified Data.Set as Set
  import qualified Data.Map as Map
  import qualified Data.IntMap as IntMap
  import Data.Array.IArray
  
  mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
  mkCanon2pgf opts gr am = do
    (an,abs) <- mkAbstr am
    cncs     <- mapM mkConcr (allConcretes gr am)
    return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
    where
      cenv = resourceValues opts gr
  
      mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
        where
          aflags = err (const noOptions) mflags (lookupModule gr am)
  
          adefs =
              [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
              Look.allOrigInfos gr am
  
          flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
  
          funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | 
                                     ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
                                     let arity = mkArity ma mdef ty]
  
          cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) |
                                     ((m,c),AbsCat (Just (L _ cont))) <- adefs]
  
          catfuns cat =
                [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
  
      mkConcr cm = do
        let cflags  = err (const noOptions) mflags (lookupModule gr cm)
  
        (ex_seqs,cdefs) <- addMissingPMCFGs
                              Map.empty 
                              ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
                               Look.allOrigInfos gr cm)
  
        let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags]
  
            seqs = (mkSetArray . Set.fromList . concat) $
                       (Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
  
            ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
  
            !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
            !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
                                  = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
          
            printnames = genPrintNames cdefs
        return (mi2i cm, D.Concr flags
                                printnames
                                cncfuns
                                lindefs
                                linrefs
                                seqs
                                productions
                                IntMap.empty
                                Map.empty
                                cnccats
                                IntMap.empty
                                fid_cnt2)
        where
          -- if some module was compiled with -no-pmcfg, then
          -- we have to create the PMCFG code just before linking
          addMissingPMCFGs seqs []                  = return (seqs,[])
          addMissingPMCFGs seqs (((m,id), info):is) = do
            (seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
            (seqs,is  ) <- addMissingPMCFGs seqs is
            return (seqs, ((m,id), info) : is)
  
  i2i :: Ident -> CId
  i2i = utf8CId . ident2utf8
  
  mi2i :: ModuleName -> CId
  mi2i (MN i) = i2i i
  
  mkType :: [Ident] -> A.Type -> C.Type
  mkType scope t =
    case GM.typeForm t of
      (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
                             in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
  
  mkExp :: [Ident] -> A.Term -> C.Expr
  mkExp scope t = 
    case t of
      Q (_,c)  -> C.EFun (i2i c)
      QC (_,c) -> C.EFun (i2i c)
      Vr x     -> case lookup x (zip scope [0..]) of
                    Just i  -> C.EVar  i
                    Nothing -> C.EMeta 0
      Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
      App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
      EInt i   -> C.ELit (C.LInt (fromIntegral i))
      EFloat f -> C.ELit (C.LFlt f)
      K s      -> C.ELit (C.LStr s)
      Meta i   -> C.EMeta i
      _        -> C.EMeta 0
  
  mkPatt scope p = 
    case p of
      A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
                     in (scope',C.PApp (i2i c) ps')
      A.PV x      -> (x:scope,C.PVar (i2i x))
      A.PAs x p   -> let (scope',p') = mkPatt scope p
                     in (x:scope',C.PAs (i2i x) p')
      A.PW        -> (  scope,C.PWild)
      A.PInt i    -> (  scope,C.PLit (C.LInt (fromIntegral i)))
      A.PFloat f  -> (  scope,C.PLit (C.LFlt f))
      A.PString s -> (  scope,C.PLit (C.LStr s))
      A.PImplArg p-> let (scope',p') = mkPatt scope p
                     in (scope',C.PImplArg p')
      A.PTilde t  -> (  scope,C.PTilde (mkExp scope t))
  
  mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
  mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                        in if x == identW
                                                             then (  scope,(bt,i2i x,ty'))
                                                             else (x:scope,(bt,i2i x,ty'))) scope hyps 
  
  mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
                                   ,generateByteCode gr arity eqs
                                   )
  mkDef gr arity Nothing    = Nothing
  
  mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
  mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
  mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
                                 in length ctxt
  
  genCncCats gr am cm cdefs =
    let (index,cats) = mkCncCats 0 cdefs
    in (index, Map.fromList cats)
    where
      mkCncCats index []                                                = (index,[])
      mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) 
        | id == cInt    = 
              let cc            = pgfCncCat gr lincat fidInt
                  (index',cats) = mkCncCats index cdefs
              in (index', (i2i id,cc) : cats)
        | id == cFloat  = 
              let cc            = pgfCncCat gr lincat fidFloat
                  (index',cats) = mkCncCats index cdefs
              in (index', (i2i id,cc) : cats)
        | id == cString = 
              let cc            = pgfCncCat gr lincat fidString
                  (index',cats) = mkCncCats index cdefs
              in (index', (i2i id,cc) : cats)
        | otherwise     =
              let cc@(C.CncCat _s e _) = pgfCncCat gr lincat index
                  (index',cats)        = mkCncCats (e+1) cdefs
              in (index', (i2i id,cc) : cats)
      mkCncCats index (_                      :cdefs) = mkCncCats index cdefs
  
  genCncFuns :: Grammar
             -> ModuleName
             -> ModuleName
             -> Array SeqId Sequence
             -> Array SeqId Sequence
             -> [(QIdent, Info)]
             -> FId
             -> Map.Map CId D.CncCat
             -> (FId,
                 IntMap.IntMap (Set.Set D.Production),
                 IntMap.IntMap [FunId],
                 IntMap.IntMap [FunId],
                 Array FunId D.CncFun)
  genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
    let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
        (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
    in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
    where
      mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
        (fid_cnt,funs_cnt,funs,lindefs,linrefs)
      mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
        let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
                         in funs_cnt+(e_funid-s_funid+1)
            lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
            linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
            funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
        in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
      mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
        mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
  
      mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
        (fid_cnt,funs_cnt,funs,prods)
      mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
        let ---Ok ty_C        = fmap GM.typeForm (Look.lookupFunType gr am id)
            ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
            !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
                             in funs_cnt+(e_funid-s_funid+1)
            !(fid_cnt',crc',prods') 
                           = foldl' (toProd lindefs ty_C funs_cnt)
                                    (fid_cnt,crc,prods) prods0
            funs'          = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
        in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
      mkCncFuns (_                                                :cdefs) fid_cnt funs_cnt funs lindefs crc prods = 
        mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
  
      toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
        let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) 
            set0    = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
            fid     = mkFId res_C fid0
            !prods' = case IntMap.lookup fid prods of
                       Just set -> IntMap.insert fid (Set.union set0 set) prods
                       Nothing  -> IntMap.insert fid set0 prods
        in (fid_cnt,crc,prods')
        where
          mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
            case fid0s of
              [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
              fid0s  -> case Map.lookup fids crc of
                          Just fid -> (st,map (flip C.PArg fid) ctxt)
                          Nothing  -> let !crc'   = Map.insert fids fid_cnt crc
                                          !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
                                      in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
            where
              (hargs_C,arg_C) = GM.catSkeleton ty
              ctxt = mapM (mkCtxt lindefs) hargs_C
              fids = map (mkFId arg_C) fid0s
  
      mkLinDefId id = prefixIdent "lindef " id
  
      toLinDef res offs lindefs (Production fid0 funid0 args) =
        if args == [[fidVar]]
          then IntMap.insertWith (++) fid [offs+funid0] lindefs
          else lindefs
        where
          fid = mkFId res fid0
  
      toLinRef res offs linrefs (Production fid0 funid0 [fargs]) =
        if fid0 == fidVar
          then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
          else linrefs
        where
          fids = map (mkFId res) fargs
  
      mkFId (_,cat) fid0 =
        case Map.lookup (i2i cat) cnccats of
          Just (C.CncCat s e _) -> s+fid0
          Nothing               -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
  
      mkCtxt lindefs (_,cat) =
        case Map.lookup (i2i cat) cnccats of
          Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
          Nothing               -> error "GrammarToPGF.mkCtxt failed"
  
      toCncFun offs (m,id) funs (funid0,lins0) =
        let mseqs = case lookupModule gr m of
                      Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
                      _                              -> ex_seqs
        in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs                                          
        where
          newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
             
          binSearch v arr (i,j)
            | i <= j    = case compare v (arr ! k) of
                            LT -> binSearch v arr (i,k-1)
                            EQ -> k
                            GT -> binSearch v arr (k+1,j)
            | otherwise = error "binSearch"
            where
              k = (i+j) `div` 2
  
  genPrintNames cdefs =
    Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
    where
      prn (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
      prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
      prn _                                = []
  
      flatten (K s)      = s
      flatten (Alts x _) = flatten x
      flatten (C x y)    = flatten x +++ flatten y
  
  --mkArray    lst = listArray (0,length lst-1) lst
  mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
  mkSetArray set = listArray (0,Set.size set-1) [v | v <- Set.toList set]
  