content: module ParseOp(parseOps,parseOp) where
  import Util(mapSndM, findSame)
  import PFPrint
  import Id
  import CSyntax
  import Fixity
  import Error(internalError, ErrMsg(..), ErrorHandle)
  import ErrorMonad(ErrorMonad(..), convErrorMonadToIO)
  import PreIds(idAssign)
  
  -- import Debug.Trace
  
  -- XXX insert fixity in identifiers
  
  type FixTable = [(Id, Fixity)]
  
  parseOps :: ErrorHandle -> CPackage -> IO CPackage
  parseOps errh (CPackage i exps imps fixs defs includes) =
      let ft = map getFixes fixs ++ concatMap getImpFixes imps in
      --trace (show ft) $
      do
         defs' <- convErrorMonadToIO errh (mapM (pDefn ft) defs)
         return (CPackage i exps imps fixs defs' includes)
  
  getFixes :: CFixity -> (Id, Fixity)
  getFixes (CInfix  p i) = (i, FInfix  (fromInteger p))
  getFixes (CInfixl p i) = (i, FInfixl (fromInteger p))
  getFixes (CInfixr p i) = (i, FInfixr (fromInteger p))
  
  getImpFixes :: CImport -> FixTable
  getImpFixes (CImpSign _ _ (CSignature _ _ fixs _)) = map getFixes fixs
  getImpFixes _ = []
  
  pDefn :: FixTable -> CDefn -> ErrorMonad CDefn
  pDefn ft (Cinstance t ds) = do
      ds' <- mapM (pDefl ft) ds
      return (Cinstance t ds')
  pDefn ft (CValueSign d) = do
      d' <- pDef ft d
      return (CValueSign d')
  
  pDefn ft def@(Cstruct _ sst idk _ fs _) =
    case sst of
         SStruct -> checkDupls def "member" "structure" (iKName idk) (map cf_name fs)
         SInterface{} -> checkDupls def "method" "interface" (iKName idk) (map cf_name fs)
         SDataCon i _ -> checkDupls def "member" "substructure of union" i (map cf_name fs)
         -- These don't exist until later:
         -- Created by MakeSymTab
         SClass -> internalError("ParseOp.pDefn: unexpected structure type: SClass\n" ++ ppReadable def)
         -- Created by Deriving
         SPolyWrap _ _ _ -> internalError("ParseOp.pDefn: unexpected structure type: SPolyWrap\n" ++ ppReadable def)
  
  pDefn ft def@(Cclass incoh cps idk is fdps fs) = do
    let pField f@(CField { cf_default = fcs }) = do
          fcs' <- mapM (pCClause ft) fcs
          return (f { cf_default = fcs' })
    fs' <- mapM pField fs
    let def' = Cclass incoh cps idk is fdps fs'
    checkDupls def' "function" "typeclass" (iKName idk) (map cf_name fs)
  
  pDefn ft def@(Cdata { cd_name = idk, cd_original_summands = ocs }) =
      checkDupls def "member" "union" (iKName idk) (concatMap cos_names ocs)
  
  pDefn ft d = return d
  
  checkDupls :: CDefn -> String -> String -> Id -> [Id] -> ErrorMonad CDefn
  checkDupls def element container_type container_name ids =
    let sameIds = findSame ids in
        if (null sameIds) then return def
        -- XXX could return all duplicates, but I think tons of duplicates are rare
        else case head sameIds of
             (dupId:sndId:_) ->
                 EMError [(getPosition sndId,
                           EDupMem (pfpString dupId) element
                                   container_type (pfpString container_name))]
             _ -> internalError "ParseOp.checkDupls"
  
  pDefl :: FixTable -> CDefl -> ErrorMonad CDefl
  pDefl ft (CLValueSign d qs) = do
      d' <- pDef ft d
      qs' <- mapM (pQual ft) qs
      return (CLValueSign d' qs')
  pDefl ft (CLValue i cs qs) = do
      cs' <- mapM (pCClause ft) cs
      qs' <- mapM (pQual ft) qs
      return (CLValue i cs' qs')
  pDefl ft (CLMatch p e) = do
      p' <- pPat ft p
      e' <- pExpr ft e
      return (CLMatch p' e')
  
  pGuard :: FixTable -> Maybe CExpr -> ErrorMonad (Maybe CExpr)
  pGuard ft Nothing = return Nothing
  pGuard ft (Just e) = pExpr ft e >>= return . Just
  
  pDef :: FixTable -> CDef -> ErrorMonad CDef
  pDef ft (CDef i t cs) = do
      cs' <- mapM (pCClause ft) cs
      return (CDef i t cs')
  pDef ft deft@(CDefT _ _ _ _) = internalError("ParseOp.pdef: typed definition: " ++ (ppReadable deft))
  
  pCClause :: FixTable -> CClause -> ErrorMonad CClause
  pCClause ft (CClause ps qs e) = do
      ps' <- mapM (pPat ft) ps
      qs' <- mapM (pQual ft) qs
      e' <- pExpr ft e
      return (CClause ps' qs' e')
  
  pQual :: FixTable -> CQual -> ErrorMonad CQual
  pQual ft (CQGen t p e) = do
      p' <- pPat ft p
      e' <- pExpr ft e
      return (CQGen t p' e')
  pQual ft (CQFilter e) = do
      e' <- pExpr ft e
      return (CQFilter e')
  
  pPat :: FixTable -> CPat -> ErrorMonad CPat
  pPat ft (CPCon i ps) = do
      ps' <- mapM (pPat ft) ps
      return (CPCon i ps')
  pPat ft (CPstruct mb i ips) = do
      ips' <- mapSndM (pPat ft) ips
      return (CPstruct mb i ips')
  pPat ft p@(CPVar _) = return p
  pPat ft (CPAs i p) = do
      p' <- pPat ft p
      return (CPAs i p')
  pPat ft p@(CPAny {}) = return p
  pPat ft p@(CPLit _) = return p
  pPat ft p@(CPMixedLit {}) = return p
  
  -- typed patterns should not appear
  pPat ft p = internalError("ParseOp.pPat: typed pattern: " ++ ppReadable p)
  
  pExpr :: FixTable -> CExpr -> ErrorMonad CExpr
  pExpr ft (CLam i e) = do
      e' <- pExpr ft e
      return (CLam i e')
  pExpr ft (Cletrec ds e) = do
      ds' <- mapM (pDefl ft) ds
      e' <- pExpr ft e
      return (Cletrec ds' e')
  pExpr ft (Cletseq ds e) = do
      ds' <- mapM (pDefl ft) ds
      e' <- pExpr ft e
      return (Cletseq ds' e')
  pExpr ft (CSelect e i) = do
      e' <- pExpr ft e
      return (CSelect e' i)
  pExpr ft (CCon i es) = do
      es' <- mapM (pExpr ft) es
      return (CCon i es')
  pExpr ft (Ccase pos e as) = do
      e' <- pExpr ft e
      let pCaseArm arm = do
              new_pattern <- pPat ft (cca_pattern arm)
              new_filters <- mapM (pQual ft) (cca_filters arm)
              new_consequent <- pExpr ft (cca_consequent arm)
              return (CCaseArm { cca_pattern = new_pattern,
                                 cca_filters = new_filters,
                                 cca_consequent = new_consequent })
      as' <- mapM pCaseArm as
      return (Ccase pos e' as')
  pExpr ft (CStruct mb i ies) = do
      ies' <- mapSndM (pExpr ft) ies
      return (CStruct mb i ies')
  pExpr ft (CStructUpd e ies) = do
      e' <- pExpr ft e
      ies' <- mapSndM (pExpr ft) ies
      return (CStructUpd e' ies')
  pExpr ft (Cwrite pos e v) = do
      e' <- pExpr ft e
      v' <- pExpr ft v
      return (Cwrite pos e' v')
  pExpr ft e@(CAny {}) = return e
  pExpr ft e@(CVar _) = return e
  pExpr ft (CApply e es) = do
      e' <- pExpr ft e
      es' <- mapM (pExpr ft) es
      return (CApply e' es')
  pExpr ft (CTaskApply e es) = do
      e' <- pExpr ft e
      es' <- mapM (pExpr ft) es
      return (CTaskApply e' es')
  pExpr ft e@(CLit _) = return e
  -- XXX it is naughty but convenient to replace
  -- := by Cwrite in ParseOp
  -- (since it is common to the Classic and BSV flows)
  pExpr ft e@(CBinOp lhs i rhs) | i `qualEq` idAssign =
    pExpr ft (Cwrite (getPosition i) lhs rhs)
  pExpr ft (CBinOp e1 o e2) = do
      e1' <- pExpr ft e1
      e2' <- pExpr ft e2
      return (CBinOp e1' o e2')
  pExpr ft (CHasType e t) = do
      e' <- pExpr ft e
      return (CHasType e' t)
  pExpr ft (Cif pos e1 e2 e3) = do
      e1' <- pExpr ft e1
      e2' <- pExpr ft e2
      e3' <- pExpr ft e3
      return (Cif pos e1' e2' e3')
  pExpr ft (CSub pos e1 e2) = do
      e1' <- pExpr ft e1
      e2' <- pExpr ft e2
      return (CSub pos e1' e2')
  pExpr ft (CSub2 e1 e2 e3) = do
      e1' <- pExpr ft e1
      e2' <- pExpr ft e2
      e3' <- pExpr ft e3
      return (CSub2 e1' e2' e3')
  pExpr ft (CSubUpdate pos e_vec (e_h, e_l) e_rhs) = do
      e_vec' <- pExpr ft e_vec
      e_h'   <- pExpr ft e_h
      e_l'   <- pExpr ft e_l
      e_rhs' <- pExpr ft e_rhs
      return (CSubUpdate pos e_vec' (e_h', e_l') e_rhs')
  pExpr ft (Cmodule pos is) = do
      is' <- mapM (pMStmt ft) is
      return (Cmodule pos is')
  pExpr ft (Cinterface pos i ds) = do
      ds' <- mapM (pDefl ft) ds
      return (Cinterface pos i ds')
  pExpr ft (CmoduleVerilog n ui ck rs ses ms vi ps) = do
      n' <- pExpr ft n
      ses' <- mapSndM (pExpr ft) ses
      return (CmoduleVerilog n' ui ck rs ses' ms vi ps)
  pExpr ft e@(CForeignFuncC { }) = return e
  pExpr ft (Cdo r ss) = do
      ss' <- mapM (pStmt ft) ss
      return (Cdo r ss')
  pExpr ft (Caction pos ss) = do
      ss' <- mapM (pStmt ft) ss
      return (Caction pos ss')
  pExpr ft (Crules ps rs) = do
      rs' <- mapM (pRule ft) rs
      return (Crules ps rs')
  pExpr ft (COper os) = do
      os' <- mapM (pOp ft) os
      parseOp ft os'
  pExpr ft e@(Cattributes _) = return e  -- XXX is this expected?
  pExpr ft e = internalError ("ParseOp.pExpr: unexpected expression: " ++ ppReadable e)
  
  pStmt :: FixTable -> CStmt -> ErrorMonad CStmt
  pStmt ft (CSBindT p name pprops t e) = do
      p' <- pPat ft p
      e' <- pExpr ft e
      return (CSBindT p' name pprops t e')
  pStmt ft (CSBind p name pprops e) = do
      p' <- pPat ft p
      e' <- pExpr ft e
      return (CSBind p' name pprops e')
  pStmt ft (CSletrec ds) = do
      ds' <- mapM (pDefl ft) ds
      return (CSletrec ds')
  pStmt ft (CSletseq ds) = do
      ds' <- mapM (pDefl ft) ds
      return (CSletseq ds')
  pStmt ft (CSExpr name e) = do
      e' <- pExpr ft e
      return (CSExpr name e')
  
  pMStmt :: FixTable -> CMStmt -> ErrorMonad CMStmt
  pMStmt ft (CMStmt s) = do
      s' <- pStmt ft s
      return (CMStmt s')
  pMStmt ft (CMrules e) = do
      e' <- pExpr ft e
      return (CMrules e')
  pMStmt ft (CMinterface e) = do
      e' <- pExpr ft e
      return (CMinterface e')
  pMStmt ft (CMTupleInterface pos es) = do
      es' <- mapM (pExpr ft) es
      return (CMTupleInterface pos es')
  
  pRule :: FixTable -> CRule -> ErrorMonad CRule
  pRule ft (CRule ps g qs e) = do
      g' <- pGuard ft g
      qs' <- mapM (pQual ft) qs
      e' <- pExpr ft e
      return (CRule ps g' qs' e')
  pRule ft (CRuleNest ps g qs rs) = do
      g' <- pGuard ft g
      qs' <- mapM (pQual ft) qs
      rs' <- mapM (pRule ft) rs
      return (CRuleNest ps g' qs' rs')
  
  pOp :: FixTable -> COp -> ErrorMonad COp
  pOp ft (CRand e) = pExpr ft e >>= return . CRand
  pOp ft e = return e
  
  parseOp :: FixTable -> [COp] -> ErrorMonad CExpr
  parseOp ft ops = doOne ft ops [] []
  
  doOne :: FixTable -> [COp] -> [(Int, Id)] -> [CExpr] -> ErrorMonad CExpr
  doOne ft [] [] [e] = return e
  doOne ft [] [] es = internalError ("ParseOp.doOne: Bad operand stack "++ppDebug es)
  doOne ft [] ((a,o):os) es = doOp ft a o [] os es
  doOne ft (CRand e:rs) os es = doOne ft rs os (e:es)
  doOne ft (CRator a iop:rs) [] es = doOne ft rs [(a,iop)] es
  doOne ft rrs@(CRator ia iop:rs) oos@((sa,sop):os) es =
          let (iprec,iass) = precOfA ft ia iop
              (sprec,sass) = precOfA ft sa sop
          in  {-if iass==FPrefix iprec && iprec <= sprec then
                  EMError (getIdPosition iop, ESyntax (ppId iop) [])
              else-}
              if iprec==sprec && (iass/=sass || iass==FInfix iprec) {- && sass /= FPrefix sprec-} then
                  EMError [(getIdPosition sop, EAmbOper (pfpString sop) (pfpString iop))]
              else if iprec>sprec || iprec==sprec && iass==FInfixr iprec then
                  doOne ft rs ((ia,iop):oos) es
              else
                  doOp ft sa sop rrs os es
  doOp :: FixTable -> Int -> Id -> [COp] -> [(Int, Id)] -> [CExpr] -> ErrorMonad CExpr
  doOp ft a op rs os es =
  {-
      if idFString op == fsMinus && a == 1 then
          case es of
              e:es' -> doOne ft rs os (ENegate e : es')
              _ -> internalError ("Bad operator arity (1) for "++pfpString op)
      else
  -}
          case es of
              e1:e2:es' -> -- XXX := to Cwrite (see above)
                           do let e' = if (op `qualEq` idAssign) then
                                         Cwrite (getPosition op) e2 e1
                                       else CBinOp e2 op e1
                              doOne ft rs os (e' : es')
              _ -> internalError ("ParseOp.doOp: Bad operator arity (2) for "++pfpString op)
  
  precOfA :: FixTable -> Int -> Id -> (Int, Fixity)
  precOfA ft _ i =
      case getIdFixity ft i of
      f@(FInfix  i) -> (i, f)
      f@(FInfixl i) -> (i, f)
      f@(FInfixr i) -> (i, f)
      i -> internalError ("ParseOp.precOfA: bad op: " ++ show i)
  
  getIdFixity :: FixTable -> Id -> Fixity
  getIdFixity ft i =
      case lookup i ft of
      Nothing -> defaultFixity
      Just f -> f
  