content: {-# Language OverloadedStrings, BlockArguments #-}
  module Daedalus.VM.Backend.C.Bitdata (cBitdata,bdCase,bdCaseDflt) where
  
  import Data.Maybe(mapMaybe)
  import Data.Map(Map)
  import Data.List(groupBy)
  
  import Daedalus.PP
  import qualified Daedalus.BDD as BDD
  
  import Daedalus.Core
  import Daedalus.Core.Type(bdUniverse)
  import Daedalus.VM.Backend.C.Lang
  import Daedalus.VM.Backend.C.Names
  import Daedalus.VM.Backend.C.Types
  
  
  -- XXX: generate documentation
  cBitdata :: NSUser => Map TName TDecl -> TDecl -> BDD.Pat -> BitdataDef -> Doc
  cBitdata allTys ty univ def =
    cNamespace nsUser
      [ "class" <+> cTyName <+>
                      ": public" <+> cInst (nsDDL .:: "Bitdata") [w] <+> "{"
      , nest 2 (vcat' privateMethods)
      , "public:"
      , nest 2 (vcat' methods)
      , "};"
      ]
  
    where
    w       = int (BDD.width univ)
    rep     = uint w
    cTyName = cTNameRoot (tName ty)
    cty     = cTNameUse GenPublic (tName ty)
  
    privateMethods =
      [ bdCon ]
  
    methods =
        defaultCon
      : fromBits
      : case def of
          BDStruct fs -> defBDStructCon w fs : mapMaybe defBDSel fs
          BDUnion  fs -> map defBDUnionCon fs ++
                         map defBDUnionSel fs ++
                         [defBDUnionCase allTys univ fs]
  
  
    fromBits = "static"
            $$ cDefineFun cty "fromBits" [rep <+> "x"]
                 [ cReturn (cCallCon (bdTy w) ["x"]) ]
  
    defaultCon = cDefineCon cTyName []                 [ (bdTy w, empty) ] []
    bdCon      = cDefineCon cTyName [ bdTy w <+> "x" ] [ (bdTy w, "x")   ] []
  
  
  defBDUnionCon :: NSUser => (Label,Type) -> CDecl
  defBDUnionCon (l,t) =
    cDefineFun "void" (unionCon l) [ cSemType t <+> "x" ]
      [ cAssign "*this" (cCall "fromBits" [ cCallMethod "x" "toBits" []]) ]
  
  defBDUnionSel :: NSUser => (Label,Type) -> CDecl
  defBDUnionSel (l,t) =
    cDefineFun (cSemType t) (selName GenOwn l) []
      [ cReturn (cCall (cSemType t .:: "fromBits") [ cCall "toBits" [] ]) ]
  
  defBDUnionCase :: Map TName TDecl -> BDD.Pat -> [(Label,Type)] -> CDecl
  defBDUnionCase allTys univ lts =
    cTemplate ["typename Cases"] $
    cDefineFun "auto" "bd_switch" ["Cases&& cases"] [
      bdCase False allTys univ "(*this)" [
        (t, cReturn (cCall "cases" [cCall (selName GenOwn l) []]))
        | (l,t) <- lts
      ]
    ]
  
  -- assumes fields are sorted
  defBDStructCon :: NSUser => CExpr -> [BDField] -> CDecl
  defBDStructCon w fs = cDefineFun "void" structCon args
                        [ cAssign "*this" (cCall "fromBits" [expr]) ]
    where
    args = [ cSemType t <+> escText l | f <- fs, BDData l t <- [bdFieldType f] ]
    expr = case fs of
             [] -> cCallCon (uint w) []
             _  -> fst (foldl1 jn (map fToExpr fs `zip` map bdWidth fs))
  
    jn (a,m) (b,n) = (cCallCon (uint (int (m+n))) [a,b], m + n)
  
  fToExpr :: BDField -> CExpr
  fToExpr f =
    case bdFieldType f of
      BDWild     -> cCallCon (uint (int (bdWidth f))) []
      BDTag n    -> cCallCon (uint (int (bdWidth f))) [integer n] -- suff?
      BDData l _ -> cCallMethod (escText l) "toBits" []
  
  
  defBDSel :: NSUser => BDField -> Maybe CDecl
  defBDSel f =
    case bdFieldType f of
      BDData l t ->
        let base    = cCall "toBits" []
            shifted = if bdOffset f == 0
                        then base
                        else parens (base <+> ">>" <+> cCallCon (nsDDL .:: "Size")
                                                        [int (bdOffset f)])
            bits = cCallCon (uint (int (bdWidth f)))
                    [ cCallMethod shifted "rawRep" [] ]
  
        in Just (cDefineFun (cSemType t) (selName GenOwn l) []
                    [ cReturn (cCall (cSemType t .:: "fromBits") [bits]) ])
  
      _ -> Nothing
  
  
  --------------------------------------------------------------------------------
  
  -- XXX: This can duplicate RHSs if there are multiple checks for a pattern
  bdCaseDflt ::
    Bool {- ^ If True, then add `break` to blocks -} ->
    Map TName TDecl -> BDD.Pat -> CExpr -> [ (Type,CStmt) ] -> CStmt -> CStmt
  bdCaseDflt addBrk allTys univ e cases dflt =
      foldr doCase dflt
    $ map rearrange
    $ groupBy sameMask
    $ BDD.patTestsAssumingInOrder univ
      [ (bdUniverse allTys t, s) | (t,s) <- cases ]
  
    where
    val = cCallMethod (cCallMethod e "toBits" []) "rep" []
  
    addBreak s
      | addBrk    = s $$ cBreak
      | otherwise = s
  
    maskedWith m
      | m == ((2 ^ BDD.width univ) - 1) = val
      | otherwise = val <+> "&" <+> integer m
  
    doCase (mask, alts) orElse
      | mask == 0 = snd (head alts)
      | otherwise =
        cSwitchDefault
          (maskedWith mask)
          [ cCase (integer v) (addBreak rhs) | (v,rhs) <- alts ]
          orElse
  
    rearrange xs = ( BDD.patMask (fst (head xs))
                   , [ (BDD.patValue t, rhs) | (t,rhs) <- xs ]
                   )
  
    sameMask (x,_) (y,_) = BDD.patMask x == BDD.patMask y
  
  bdCase ::
    Bool -> Map TName TDecl -> BDD.Pat -> CExpr -> [ (Type,CStmt) ] -> CStmt
  bdCase addBreak allTys univ e cases =
    bdCaseDflt addBreak allTys univ e cases
                                          (cStmt (cCall "assert" [ "false" ]))
  
  --------------------------------------------------------------------------------
  uint :: CExpr -> CType
  uint n = cInst (nsDDL .:: "UInt") [n]
  
  bdTy :: CExpr -> CType
  bdTy n = cInst (nsDDL .:: "Bitdata") [n]
  