module Derive.Binary (deriveBinary) where

import List
import Syntax
import MkSyntax(mkInt)
import IntState
import Id
import IdKind
import NT
import State
import Derive.Lib
import TokenId(t_Tuple,t_Colon,t_List,
               tBinary,t_get,t_put,t_getF,t_sizeOf,
               t_putBits,t_getBits,t_getBitsF,
               t_gtgt,t_gtgteq,t_return,t_ltlt,t_plus)

deriveBinary :: ((TokenId, IdKind) -> Id)
             -> Id -> Id -> [Id] -> [(Id, Id)] -> Pos
             -> State d IntState (Decl Id) IntState
deriveBinary tidFun cls typ tvs ctxs pos =
 getUnique >>>= \d ->
 let iPut  = tidFun (t_put,Method)
     iGet  = tidFun (t_get,Method)
     iFGet = tidFun (t_getF,Method)
     iSize = tidFun (t_sizeOf,Method)

     expPut  = ExpVar pos iPut
     expGet  = ExpVar pos iGet
     expFGet = ExpVar pos iFGet
     expSize = ExpVar pos iSize

     expPair   = ExpCon pos (tidFun (t_Tuple 2,Con))
     expCons   = ExpCon pos (tidFun (t_Colon,Con))
     expNil    = ExpCon pos (tidFun (t_List,Con))
     expPutBits = ExpVar pos (tidFun (t_putBits,Var))
     expGetBits = ExpVar pos (tidFun (t_getBits,Var))
     expGetBitsF  = ExpVar pos (tidFun (t_getBitsF,Var))
     expLtLt   = ExpVar pos (tidFun (t_ltlt,Var))
     expGtGt   = ExpVar pos (tidFun (t_gtgt,Var))
     expGtGtEq = ExpVar pos (tidFun (t_gtgteq,Var))
     expReturn = ExpVar pos (tidFun (t_return,Var))
     expPlus   = ExpVar pos (tidFun (t_plus,Var))
 in
  getInfo typ >>>= \ typInfo -> 
  mapS getInfo (constrsI typInfo) >>>= \ constrInfos ->
  let sizeC = ((ceiling . logBase 2 . fromIntegral . length) constrInfos)::Int
  in
    addInstMethod tBinary (tidI typInfo) t_put (NewType tvs [] ctxs [mkNTcons typ (map mkNTvar tvs)]) iPut >>>= \ funP ->
    addInstMethod tBinary (tidI typInfo) t_get (NewType tvs [] ctxs [mkNTcons typ (map mkNTvar tvs)]) iGet >>>= \ funG ->
    addInstMethod tBinary (tidI typInfo) t_getF (NewType tvs [] ctxs [mkNTcons typ (map mkNTvar tvs)]) iFGet >>>= \ funF ->
    addInstMethod tBinary (tidI typInfo) t_sizeOf (NewType tvs [] ctxs [mkNTcons typ (map mkNTvar tvs)]) iSize >>>= \ funS ->
    mapS (mkPutFun expPutBits expPut expGtGt expGtGtEq expReturn sizeC pos) (zip [0..] constrInfos) >>>= \ funPs ->
    mkGetFuns expGetBits expGet expGtGtEq expReturn expCons expNil sizeC pos typInfo constrInfos >>>= \ funGs ->
    mkFGetFuns expGetBitsF expFGet expLtLt expPair expCons expNil sizeC pos typInfo constrInfos >>>= \ funFs ->
    mapS (mkSizeFun sizeC expSize expPlus pos) constrInfos >>>= \ funSs ->
    unitS $
      DeclInstance pos (syntaxCtxs pos ctxs) cls [syntaxType pos typ tvs] $
        DeclsParse [DeclFun pos funP funPs
                   ,DeclFun pos funG funGs
                   ,DeclFun pos funF funFs 
                   ,DeclFun pos funS funSs]



mkPutFun :: Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id
            -> Int -> Pos -> (Int, Info)
            -> State d IntState (Fun Id) IntState
mkPutFun expPutBits expPut expGtGt expGtGtEq expReturn sizeC pos (numC,constrInfo) =
  getUnique >>>= \bh->
  let 
    --conTid = dropM (tidI constrInfo)
      con = ExpCon pos (uniqueI constrInfo)
      expBH = ExpVar pos bh
      expPutCon = ExpApplication pos [expPutBits, expBH, mkInt pos sizeC, mkInt pos numC]
  in case ntI constrInfo of
     NewType _ _ _ [nt] -> -- This constructor has no arguments
       unitS (Fun [expBH,con] (Unguarded expPutCon) (DeclsParse []))
     NewType _ _ _ (_:nts) ->  -- We only want a list with one element for each argument, the elements themselves are never used
       mapS ( \ _ -> unitS (ExpVar pos) =>>> getUnique) nts >>>= \(fstarg:args) ->
       getUnique >>>= \ h ->
       let expH = ExpVar pos h
           expPutArg arg = ExpApplication pos [expPut,expBH,arg]
       in unitS 
            (Fun [expBH,ExpApplication pos (con:fstarg:args)]
              (Unguarded 
                (ExpApplication pos
                  [expGtGtEq
                  ,expPutCon
                  ,ExpLambda pos [expH]
                    (ExpApplication pos 
                      [expGtGt
                      ,(foldl (\z arg -> 
                         ExpApplication pos [expGtGt,z,expPutArg arg])
                         (expPutArg fstarg)
                         args)
                      ,ExpApplication pos [expReturn,expH]])]))
              (DeclsParse []))


-- this code is modified from *showType*, not from *readsPrec*.
mkGetFuns :: Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id
          -> Int -> Pos -> Info -> [Info]
          -> State d IntState [Fun Id] IntState
mkGetFuns expGetBits expGet expGtGtEq expReturn expCons expNil sizeC pos typInfo constrInfos =
  getUnique >>>= \ i ->
  getUnique >>>= \ bh ->
  let expI      = ExpVar pos i
      expBH     = ExpVar pos bh
      expGetCon = ExpApplication pos [expGetBits, expBH, mkInt pos sizeC]
  in
   --mkListExp pos expCons expNil expGtGtEq expGet expBH expReturn constrInfos >>>= \listExp->
     mkAltList pos (mkGetExp pos expGtGtEq expGet expBH expReturn) constrInfos >>>= \altList->
     unitS [Fun [expBH]
             (Unguarded 
               (ExpApplication pos
                 [expGtGtEq
                 ,expGetCon
                 ,ExpLambda pos [expI] (ExpCase pos expI altList)
                 ]))
             (DeclsParse [])]

mkGetExp :: Pos -> Exp id -> Exp id -> Exp id -> Exp id -> Exp id
         -> [Exp id] -> Info
         -> Exp id
mkGetExp pos expGtGtEq expGet expBH expReturn expCon args constrInfo =
  foldr (\ arg z -> ExpApplication pos [expGtGtEq, (ExpApplication pos [expGet,expBH]), ExpLambda pos [arg] z])
        (ExpApplication pos [expReturn,
                             ExpApplication pos (expCon:args)])
        args


mkAltList :: Pos
             -> (Exp Id -> [Exp Id] -> Info -> Exp id)
             -> [Info]
             -> State d IntState [Alt id] IntState
mkAltList pos mkExpFun constrInfos =
  mapS (\(n,constrInfo) ->
         let expCon = ExpCon pos (uniqueI constrInfo)
             expN   = mkInt pos n
         in
         case ntI constrInfo of
           NewType _ _ _ (_:nts) ->
             mapS ( \ _ -> unitS (ExpVar pos) =>>> getUnique) nts >>>= \args ->
             unitS (Alt expN
                     (Unguarded (mkExpFun expCon args constrInfo))
                     (DeclsParse []))
       )
       (zip [0..] constrInfos)



-- this code is modified from *showType*, not from *readsPrec*.
mkFGetFuns :: Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id
           -> Int -> Pos -> Info -> [Info]
           -> State d IntState [Fun Id] IntState
mkFGetFuns expGetBitsF expFGet expLtLt expPair expCons expNil sizeC pos typInfo constrInfos =
  getUnique >>>= \ bh ->
  getUnique >>>= \ p ->
  getUnique >>>= \ p' ->
  getUnique >>>= \ n ->
  let expBH = ExpVar pos bh
      expP  = ExpVar pos p
      expP' = ExpVar pos p'
      expN  = ExpVar pos n
      expInit   = ExpApplication pos [expGetBitsF, expBH, mkInt pos sizeC, expP]
      expFGetBH = ExpApplication pos [expFGet, expBH]
  in
     mkAltList pos (mkGetFExp pos expLtLt expFGetBH expPair expP') constrInfos >>>= \altList->
     unitS [Fun [expBH,expP]
             (Unguarded 
               (ExpLet pos 
                 (DeclsParse 
                   [DeclPat 
                     (Alt (ExpApplication pos [expPair,expN,expP'])
                        (Unguarded expInit) (DeclsParse []))])
                 (ExpCase pos expN altList)
               ))
              (DeclsParse [])]

mkGetFExp :: Pos -> Exp id -> Exp id -> Exp id -> Exp id -> Exp id
          -> [b] -> Info
          -> Exp id
mkGetFExp pos expLtLt expFGetBH expPair expP' expCon args constrInfo =
    foldl (\ acc arg -> ExpApplication pos [expLtLt, acc, expFGetBH])
          (ExpApplication pos [expPair,expCon,expP'])
          args


mkSizeFun :: Int -> Exp Id -> Exp Id -> Pos -> Info
          -> State d IntState (Fun Id) IntState
mkSizeFun sizeC expSize expPlus pos constrInfo =
  let
      con           = ExpCon pos (uniqueI constrInfo)
      expCsize      = mkInt pos sizeC
      expSizeOf arg = ExpApplication pos [expSize,arg]
  in case ntI constrInfo of
     NewType _ _ _ (_:nts) ->
       mapS ( \_ -> unitS (ExpVar pos) =>>> getUnique) nts >>>= \args ->
       unitS (
         Fun [ExpApplication pos (con:args)]
           (Unguarded 
             (foldl (\z arg-> 
               ExpApplication pos [expPlus,expSizeOf arg,z]) 
               expCsize args))
           (DeclsParse []))