Remove1_3

module Remove1_3(removeDecls,mkSel,removeDo,translateExpRecord) where

import Syntax
import State
import IntState
import TokenId(TokenId,t_gtgt,t_gtgteq,t_zero)
import TypeLib(getState,newIdent,getIdent,typeError)
import SyntaxPos
import TypeData(TypeMonad)
import NT
import IdKind
import Extra(strPos,dropJust,isJust,isNothing,mixCommaAnd,noPos,dropRight
            ,isRight)
import List
import Id(Id)

type SelectorMonad a = State () ([Id],IntState) a ([Id],IntState)
-- () -> ([Id],IntState) -> (a,([Id],IntState))

removeDecls :: Decls Id -> ((TokenId,IdKind) -> Id) -> IntState 
            -> (Decls Id   -- modified declarations
               ,[Id]       -- identifiers of all data constructors
               ,IntState)

removeDecls (DeclsParse decls) tidFun state =
  case mapS removeDecl decls () ([],state) of
    (decls,(zcons,state)) -> (DeclsParse (concat decls),zcons,state)

removeDecl :: Decl Id -> SelectorMonad [Decl Id]

removeDecl (DeclConstrs pos zcon cs) =
  remember zcon >>>= \_ ->
  mapS mkSel cs
removeDecl d = unitS [d]

mkSel :: (Pos -- point of definition of selector, i.e in type definition
         ,Id  -- field name id
         ,Id) -- selector name id
         -> SelectorMonad (Decl Id)

mkSel (pos,field,selector) = 
  r13Info field >>>= \  (InfoField unique tid icon_offs iData iSel) ->
  mapS (mkFun pos) icon_offs >>>= \ alts ->
  unitS (DeclFun pos selector alts)

mkFun :: Pos 
      -> (Id,Int) -- (data constructor, offset)
      -> SelectorMonad (Fun Id)

mkFun pos (c,i) =
  r13Info c >>>= \ conInfo ->
  r13Unique >>>= \ v ->
  let wildcard = PatWildcard pos
      var = ExpVar pos v
      vars = take (arityI conInfo) (repeat wildcard)  
               -- arityI safe for constructors :-)
  in
    unitS (Fun [ExpApplication pos (ExpCon pos c : onePos var i vars)] 
             (Unguarded var) (DeclsParse []))

onePos :: a -> Int -> [a] -> [a]

onePos v 1 (x:xs) = v:xs
onePos v n (x:xs) = x: onePos v (n-1 ::Int) xs


r13Info :: Id -> SelectorMonad Info

r13Info    i down thread@(zcon,state) = (dropJust (lookupIS state i),thread)

r13Unique :: SelectorMonad Id

r13Unique  down  thread@(zcon,state) = 
  case uniqueIS state of
   (u,state) -> (u,(zcon,state))


remember :: Id -> SelectorMonad ()

remember zcon down thread@(zcons,state) = ((),(zcon:zcons,state))

removeDo :: [Stmt Id] -> TypeMonad (Exp Id)

removeDo [StmtExp exp] = unitS exp
removeDo (StmtExp exp:r) =
  let pos = getPos exp
  in 
    getIdent (t_gtgt,Var) >>>= \ gtgt ->
    removeDo r >>>= \ exp2 ->
    unitS (ExpApplication pos [ExpVar pos gtgt, exp, exp2])
removeDo (StmtLet decls :r) =
  let pos = getPos decls
  in 
    removeDo r >>>= \ exp2 ->
    unitS (ExpLet pos decls exp2)
removeDo (StmtBind pat exp:r) =
  getIdent (t_gtgteq,Var) >>>= \ gtgteq ->
  getState >>>= \ state ->
  removeDo r >>>= \ exp2 ->
  let pos = getPos exp
  in
    if nofail state pat
    then  
      unitS (ExpApplication pos [ExpVar pos gtgteq, exp, ExpLambda pos [pat] exp2])
    else
      getIdent (t_zero,Var) >>>= \ zero ->	-- In H98, this is `fail'
      newIdent >>>= \ x ->
      let eX = ExpVar pos x
          eFail = ExpApplication pos [ExpVar pos zero
                                     ,ExpLit pos (LitString Boxed "pattern-match failure in do expression")]
      in unitS 
           (ExpApplication pos 
             [ExpVar pos gtgteq
	     ,exp 
	     ,ExpLambda pos [eX] 
               (ExpCase pos eX 
                 [Alt pat (Unguarded exp2) (DeclsScc [])
		 ,Alt (PatWildcard pos) (Unguarded eFail) (DeclsScc [])
		 ])])

nofail :: IntState -> Pat Id -> Bool

nofail state (ExpCon pos con) =
  case lookupIS state con of
    Just (InfoConstr unique tid fix nt fields iType) ->
      case lookupIS state iType of
	Just (InfoData   unique tid exp nt dk) ->
	  case dk of
	    (DataNewType unboxed constructors) -> True
	    (Data unboxed  constrs) -> length constrs == 1
nofail state (ExpVar _ _) = True
nofail state (ExpApplication pos es) = all (nofail state) es
nofail state (PatWildcard _) = True
nofail state (PatAs _ _ pat) = nofail state pat
nofail state (PatIrrefutable pos pat) = True
nofail state _ = False

fieldInfo :: IntState
          -> Field Id 
          -> (Id  -- type constructor
             ,([(Id,Int)] -- data constructors with offsets for field
             ,Exp Id))   -- expressions from "field=exp"

fieldInfo state (FieldExp pos field exp) =
  case lookupIS state field of
    Just (InfoField unique tid icon_offs idata iSel) -> (idata,(icon_offs,exp))

fixArg :: Eq a => [(a,b)] -> (a,b) -> b

fixArg given (i,def) =
  case lookup i given of
    Just e -> e
    Nothing -> def

fixAlt :: Pos 
       -> [Exp Id]   -- arguments for offsets
       -> (Id,[Int]) -- (data constructor, offsets)
       -> IntState
       -> (Alt Id,IntState)

fixAlt pos exps (con,offsets) state =
  (Alt (ExpApplication pos (econ:vars))
       (Unguarded 
         (ExpApplication pos 
           (econ : map (fixArg (zip offsets exps)) (zip nargs vars))))
       (DeclsScc [])
  ,state')
  where
  nargs = [1 .. arityIS state con]
  (newNIds,state') = uniqueISs state nargs
  vars = map (ExpVar noPos . snd) newNIds 
  econ = ExpCon pos con


getOffsets :: [[(Id,Int)]] -> Id -> Either (Id,[Maybe Int]) (Id,[Int])

getOffsets icon_offs con =
  let offsets   = map (\ icon_off -> lookup con icon_off) icon_offs
  in if all isJust offsets
     then Right (con,map dropJust offsets)
     else Left (con,offsets)

translateExpRecord :: Exp Id -> [Field Id] -> IntState
                -> (Either String (Exp Id),IntState)

translateExpRecord e@(ExpRecord exp' fields') fields state = 
  translateExpRecord exp' (fields ++ fields') state
translateExpRecord e@(ExpCon pos con) fields state = 
  let coes = map (fieldInfo state) fields 
  in  if firstIsEqual coes
      then 
	let (icon_offs,exps) = unzip (map snd coes)
	in case getOffsets icon_offs con of
	    Right (con,offsets) ->
	      (Right (ExpApplication pos (e:map (fixArg (zip offsets exps))
					     (zip [1 .. arityIS state con]
                                                (repeat (PatWildcard  pos)) 
                                             ) ))
              ,state)
	    Left (con,offsets) -> 
              (Left (errField1 state pos con offsets fields)
              ,state)
      else (Left (errField2 state fields),state)
translateExpRecord exp [] state =
  (Left (errField4 (getPos exp)),state)
translateExpRecord exp fields state =
  let coes@((t,_):_) = map (fieldInfo state) fields
  in  if firstIsEqual coes -- all fields belong to same data type
      then
	let (icon_offs,exps) = unzip (map snd coes)
	    pos = getPos exp
	in case (partition isRight . map (getOffsets icon_offs) . 
                 constrsI  . dropJust . lookupIS state) t of
	  ([],_)  -> (Left (errField3 state fields),state)
	  (rps,_) -> let consFixAlt rps (alts,state) = 
                           case fixAlt pos exps rps state of 
                             (alt,state') -> (alt:alts,state')
                         (alts,state') = foldr consFixAlt ([],state) 
                                           (map dropRight rps)
                     in (Right (ExpCase (getPos exp) exp alts), state')
      else (Left (errField2 state fields),state)

firstIsEqual :: Eq a => [(a,b)] -> Bool

firstIsEqual [] = True
firstIsEqual ((k,_):kvs) = all (k==) (map fst kvs)  


errField1 :: IntState -> Pos -> Id -> [Maybe a] -> [Field Id] -> String

errField1 state pos con offsets fields =
  "The field(s)" ++ 
  mixCommaAnd (map (\(_,FieldExp pos field exp) -> ' ':show (tidIS state field)
                    ++ " at " ++ strPos pos)
		   (filter (isNothing.fst) (zip offsets fields)))
  ++ " do(es) not belong to constructor " ++ show (tidIS state con) ++ 
  " used at " ++ strPos pos ++ "."


errField2 :: IntState -> [Field Id] -> String

errField2 state fields =
  "The fields" ++ 
  mixCommaAnd (map (\(FieldExp pos field exp) -> ' ': show (tidIS state field)
                      ++ " at " ++ strPos pos)
		   fields)
  ++ " do not belong to the same type."


errField3 :: IntState -> [Field Id] -> String

errField3 state fields =
  "The fields " ++ 
  mixCommaAnd (map (\(FieldExp pos field exp) -> ' ':show (tidIS state field)
                    ++ " at " ++ strPos pos)
	       fields)
  ++ " do not belong to the same constructor."


errField4 :: Pos -> [Char]

errField4 pos =
  "The update of the expression at " ++ strPos pos ++ 
  " uses an empty list of fields."