module Translate (collect_paradigms) where

import Extract.Abs 
import Extract.ErrM
import Extract.Print
import RegExp
import System.IO.Unsafe
import qualified Types as Types

{- Collects all regular expression macros that appear at the top level.-}
get_global_reg :: [Def] -> [(String,RegExp)]
get_global_reg g = toRegExp [(i,r) | (Regdef (Ident i) r) <- g] []

toRegExp :: [(String,Extract.Abs.Reg)] -> [(String,RegExp)] -> [(String,RegExp)]
toRegExp        []  res = res
toRegExp ((i,r):xs) res = toRegExp xs ((i,f r):res) 
        where f r = 
               case r of
                RAlt reg0 reg  -> or_r (f reg0) (f reg)
                RSeq reg0 reg  -> conc (f reg0) (f reg)
                RStar reg      -> star (f reg)
                RPlus reg      -> plus (f reg)
                RDigit    -> digit
                RLetter   -> letter
                RUpper    -> upper
                RLower    -> lower
                RAny      -> char
                RAlts s   -> str_class s
                RStr s    -> str s 
                RegVar id@(Ident i) -> 
                    case lookup i res of -- Macro expansion
                     Just r  -> r
                     Nothing -> error $ "Unknown identifier " ++ i

get_context :: [Def] -> [(String,RegExp)] -> [(String,Types.Constraint)]
get_context g env = [(i,translate_constraint r env) | (Cxtdef (Ident i) r) <- g]

translate_constraint :: CLogic -> [(String,RegExp)] -> Types.Constraint
translate_constraint l env = 
    case l of
      CConj l1 l2 -> Types.Conj (translate_constraint l1 env) (translate_constraint l2 env)
      CDisj l1 l2 -> Types.Disj (translate_constraint l1 env) (translate_constraint l2 env)
      CNeg  l1    -> Types.Neg (translate_constraint l1 env)
      CLWild      -> error "'_' may not appear as atom in constraint"
      CAtom pos reg u patt -> Types.Atom $ (translate_pos pos, translate_reg reg env, translate_patt (u,patt))

translate_pos :: Position -> Maybe Types.Position
translate_pos  p = 
    case p of
     WPos  -> Nothing
     _     -> 
       Just $ 
        case p of
         (Pos (P i))                  -> Types.Relative (fromInteger i)
         (Pos (PP i))                  -> Types.Relative (fromInteger i)
         (Pos (NP i))                 -> Types.Relative (fromInteger (negate i))
         (Pos (PStar i))              -> Types.Spanning (fromInteger i) Nothing
         (Pos (NPStar i))             -> Types.Spanning (fromInteger (negate i)) Nothing
         (VPos (Ident id) (PStar i))  -> Types.Spanning (fromInteger i) (Just id)
         (VPos (Ident id) (NPStar i)) -> Types.Spanning (fromInteger (negate i)) (Just id)
         (Rel (Ident id) (PStar i))                -> Types.VarSpanning id (fromInteger i) Nothing
         (Rel (Ident id) (NPStar i))               -> Types.VarSpanning id (fromInteger (negate i)) Nothing
         (Rel (Ident id) (Star))                   -> Types.VarSpanning id 0 Nothing
         (RVPos (Ident id) (Ident id2) (PStar i))  -> Types.VarSpanning id2 (fromInteger i) (Just id)
         (RVPos (Ident id) (Ident id2) (NPStar i)) -> Types.VarSpanning id2 (fromInteger (negate i)) (Just id)
         (RVPos (Ident id) (Ident id2) (Star)) -> Types.VarSpanning id2 0 (Just id)
         (Rel (Ident id) (P i))       -> Types.Reference id (fromInteger i)
         (Rel (Ident id) (PP i))       -> Types.Reference id (fromInteger i)
         (Rel (Ident id) (NP i))      -> Types.Reference id (fromInteger (negate i))
         (VPos _ _) -> error "Variables may not be used on fixed positions."


translate_reg (Wild) _   = Nothing
translate_reg r      env = Just $ translate_to_reg r env

translate_patt :: (Unique,Patt) -> Maybe (Types.Unique,Types.Patt String)
translate_patt (_,PWild) = Nothing
translate_patt (u,x) = case u of
                         U -> Just $ (True  , translate_patt' x)
                         _ -> Just $ (False , translate_patt' x)
 where
  translate_patt' x = case x of
   PC (Ident i) p1  -> Types.P i (map translate_patt' p1)
   PWild            -> Types.PW
   PId (Ident id)   -> Types.PId id

{- create a Reg -}
translate_to_reg :: Extract.Abs.Reg -> [(String,RegExp)] -> RegExp.Reg
translate_to_reg r table =  createReg (regExp r) table
 where
  regExp r = 
   case r of
    RAlt reg0 reg       -> or_r (regExp reg0) (regExp reg)
    RSeq reg0 reg       -> conc (regExp reg0) (regExp reg)
    RStar reg           -> star (regExp reg)
    RPlus reg           -> plus (regExp reg)
    RDigit              -> digit
    RLetter             -> letter
    RUpper              -> upper
    RLower              -> lower
    RAny                -> char
    RStr s              -> str s 
    RegVar id@(Ident i) -> var i

collect_paradigms :: Grammar -> Err Types.Paradigms
collect_paradigms (Grammar xs) = return $
    [ let p_env = translate_env env in
       (id,i,translate_head h cxt_g p_env, translate_body l cxt_g p_env,p_env) | (i,Paradigm (Ident id) env h l) <- zip ns xs] ++
    [ let p_env = translate_env env in
       (id,i,translate_head h cxt_g p_env, translate_body l cxt_g p_env,p_env) | (i,RParadigm (Ident id) env h l) <- zip ns xs]
 where reg_g = get_global_reg xs
       cxt_g = get_context xs reg_g
       ns    = map show [0..]
       translate_env (Empty)    = []
       translate_env (Env env)  = toRegExp [(id,r) | (Assoc (Ident id) r) <- env] reg_g


translate_head (Head ps) cxt env = map translate_pattern ps
 where translate_pattern (CWord is NoCons) = (translate_items_regexp is,Nothing)
       translate_pattern (CWord is (Cons cons))   = (translate_items_regexp is, Just (translate_constraint cons env))
       translate_pattern (CWord is (ConsId (Ident c))) = 
        case lookup c cxt of
         Just cons -> (translate_items_regexp is, Just cons)
         Nothing   -> error $ "Unknown context id: " ++ c

translate_items :: [Item] -> Extract.Abs.Reg
translate_items xs  =
      case xs of
        [x]    -> tr_i x
        (x:xs) -> RSeq (tr_i x) (translate_items xs)
  where tr_i (StrC s) = RStr s
        tr_i (Var i)  = RegVar i

translate_items_regexp :: [Item] -> RegExp
translate_items_regexp xs  =
      case xs of
        [x]    -> tr_i x
        (x:xs) -> conc (tr_i x) (translate_items_regexp xs)
  where tr_i (StrC s) = str s
        tr_i (Var (Ident i))  = var i


-- translate_body :: Extract.Abs.Logic -> Types.Context -> Types.VarEnv -> Types.Body
translate_body logic cxt env = 
  case logic of
    Conj l1 l2 -> Types.Conj (translate_body l1 cxt env) (translate_body l2 cxt env)
    Disj l1 l2 -> Types.Disj (translate_body l1 cxt env) (translate_body l2 cxt env)
    Neg  l1    -> Types.Neg (translate_body l1 cxt env)
    LWild      -> error "_ may not appear as atom in body"
    Atom (CWord is (ConsId (Ident c))) -> 
      case lookup c cxt of
        Just cons -> let r = translate_items is 
                         r2 = translate_items_regexp is  
                         in
                        Types.Atom ((translate_to_reg r env, r2), Just cons)
        Nothing   -> error $ "Unknown context id: " ++ c
    Atom (CWord is NoCons) -> let r  = translate_items is
                                  r2 = translate_items_regexp is in 
                              Types.Atom ((translate_to_reg r env,r2),Nothing)
    Atom (CWord is (Cons cons))   
        -> let r  = translate_items is 
               r2 = translate_items_regexp is  
            in 
            Types.Atom ((translate_to_reg r env,r2),Just (translate_constraint cons env))
    _ -> error $ "Constraint without word form: " ++ printTree logic