{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

-- |Pretty Instance for Value (displays a Value as the corresponding Haskell value)
module ZM.Pretty.Value () where

import qualified Data.ByteString                as B
import           Data.Char                      (chr)
import           Data.Flat
import           Data.Int
import           Data.Maybe
import           Data.Model
import qualified Data.Sequence                  as S
import           ZM.Abs
import           ZM.BLOB
import           ZM.Pretty
import           ZM.Type.Array          (Bytes)
import           ZM.Types
import           Data.Word
import           Data.ZigZag
import           Text.PrettyPrint.HughesPJClass
-- import Debug.Trace

default ()

-- |Pretty print a Value as the corresponding Haskell value
instance Pretty Value where
     pPrintPrec (PrettyLevel lev) _ = pp 0
       where -- TODO: fix precedence
         pp :: Int -> Value -> Doc
         pp l v@(Value t n bs vs) =
           let (complex,doc) = case prettyPrinter t of
                 --Nothing -> (False,[text $ "NOT FOUND "++ show t])
                 Nothing -> (not (null vs),text n : map (pp (l+1)) vs)
                 Just pr -> let (c,d) = pr v in (c,[d])

           in (if complex && l>0 then parens else id) (hsep $ (if null bs || lev == 0 then empty else (text (map (\b -> if
 b then '1' else '0') bs) <> char ':')) : doc) -- : if lev == 0 then empty else )

         ch (Value _ _ _ [w]) = chr $ wl_ w
         ch v = error (show v)

         wrd = int . wrd_

         wrd_ (Value _ ('V':n) _ _) = read n :: Int -- Word64?
         wrd_ v                              = error (unwords ["wrd_",show v])

         wrd2_ (Value _ _ _ [Value _ ('V':n) _ _]) = read n :: Int
         wrd2_ v = error (unwords ["wrd2_",show v])

         -- i :: forall a . Proxy a -> (AbsType, Value -> (Bool, Doc))
         -- i p = (absType p,\v -> (False,int . (zzDecode::(Bits a,Integral a) => Word64 -> a) . wl_ . p0 . p0 $ v))

         wl = text . show . (wl_::Value -> Word64)

         wl_ (Value _ _ _ [Value _ _ _ [Value _ _ _ [vl]]]) = fromIntegral . fst . foldl (\(t,e) n -> (t+n*2^e,e+7)) (0::Int,0::Int) . map wrd2_ . neList $ vl

         wl_ v = error (unwords ["wl_",show v])

         valList (Value _ "Cons" _ [h,t]) = h:valList t
         valList (Value _ "Nil"  _ [])    = []
         valList v                      = error (unwords ["valList",show v])

         neList (Value _ "Cons" _ [h,t]) = h:neList t
         neList (Value _ "Elem"  _ [e])  = [e]
         neList v                      = error (unwords ["neList",show v])

         arrList (Value _ "A0" _ []) = []
         arrList (Value _ ('A':n) _ vs) | length vs == read n + 1 = init vs ++ arrList (last vs)

         arr = arr_ (pp 0)
         ar = prettyList_ (pp 0)

         tup = prettyTuple_ (pp 0)

         p0 (Value _ _ _ [v]) = v

         tuple (Value _ _ _ vs) = (False,tup vs)

         -- BUG: why is this occasionally failing?
         prettyPrinter t = listToMaybe . map snd . filter fst . map (\(t2,p) -> (match t t2,p)) $ [
            (absType (Proxy::Proxy ()),\_ -> (False,text "()"))
           ,(absType (Proxy::Proxy Word8),\v -> (False,wrd v))
           ,(absType (Proxy::Proxy Word16),\v -> (False,wl v))
           ,(absType (Proxy::Proxy Word32),\v -> (False,wl v))
           ,(absType (Proxy::Proxy Word64),\v -> (False,wl v))
           ,(absType (Proxy::Proxy Word),\v -> (False,wl v))
           ,(absType (Proxy::Proxy Int8),\v -> (False,int . zzDecode . wrd_ . p0 . p0 $ v))
           ,(absType (Proxy::Proxy Int16),\v -> (False,int . fromIntegral . zzDecode16 . wl_ . p0 . p0 $ v))
           ,(absType (Proxy::Proxy Int32),\v -> (False,int . fromIntegral . zzDecode32 . wl_ . p0 . p0 $ v))
           ,(absType (Proxy::Proxy Int64),\v -> (False,int . fromIntegral . zzDecode64 . wl_ . p0 . p0 $ v))
           ,(absType (Proxy::Proxy Int),\v -> (False,int . fromIntegral . zzDecode64 . wl_ . p0 . p0 $ v))
           ,(absType (Proxy::Proxy Integer),\v -> (False,int . fromIntegral . zzDecodeInteger . wl_ . p0 $ v))
           --,(absType (Proxy::Proxy Natural),\v -> (False,int . fromIntegral . zzDecodeInteger . wl_ . p0 $ v))
           ,(absType (Proxy::Proxy Float),\v -> (False,float $ floatVal v)) -- (False,int . fromIntegral . zzDecodeInteger . wl_ . p0 $ v))
           ,(absType (Proxy::Proxy Double),\v -> (False,double $ doubleVal v)) -- (False,int . fromIntegral . zzDecodeInteger . wl_ . p0 $ v))
           --,(absType (Proxy::Proxy Char),\v -> (False,text ['\'',ch v,'\'']))
           ,(absType (Proxy::Proxy Char),\v -> (False,pPrint (ch v)))
           --,(absType (Proxy::Proxy [Char]),\v -> (False,pPrint . map ch . valList $ v))
           ,(absType (Proxy::Proxy [Char]),\v -> (False,text . show . map ch . valList $ v))
           --,(absType (Proxy::Proxy ([Char])),\v -> (False,char '"' <> (text . map ch . valList $ v) <> char '"'))
           ,(absType (Proxy::Proxy [Any]),\v -> (False,ar (valList v)))
           ,(absType (Proxy::Proxy (NonEmptyList Any)),\v -> (False,ar (neList v)))
           ,(absType (Proxy::Proxy (S.Seq Char)),\v -> (False,pPrint . map ch . arrList $ v))
           ,(absType (Proxy::Proxy (S.Seq Any)),\v -> (False,arr (arrList v)))
           --,(absType (Proxy::Proxy (P.Array Char)),\v -> (False,pPrint . map ch . arrList $ v))
           ----,(absType (Proxy::Proxy (P.Array Any)),\v -> (True,arr (arrList v)))
           --,(absType (Proxy::Proxy (P.Array Any)),\v -> (False,arr (arrList v)))
           ,(absType (Proxy::Proxy Bytes),\v -> (False,pPrint . bytes $ v))
           ,(absType (Proxy::Proxy (BLOB UTF8Encoding)),utf8Text)
           ,(absType (Proxy::Proxy (BLOB UTF16LEEncoding)),utf16Text)
           ,(absType (Proxy::Proxy (Any,Any)),tuple)
           ,(absType (Proxy::Proxy (Any,Any,Any)),tuple)
           ,(absType (Proxy::Proxy (Any,Any,Any,Any)),tuple)
           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any)),tuple)
           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any,Any)),tuple)
           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any,Any,Any)),tuple)
           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any,Any,Any,Any)),tuple)
           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any,Any,Any,Any,Any)),tuple)
           ]
             where
               utf16Text bl = (False,pPrint . blob UTF16LEEncoding . blobBytes $ bl)
               utf8Text bl = (False,pPrint . blob UTF8Encoding . blobBytes $ bl)
               --utf8Text blob = (False,decText T.decodeUtf8 blob)
               -- decText dec = text . T.unpack . dec . blobBytes
               blobBytes b =let [_,bs] = valFields b in bytes bs
               bytes bs = let [_,vs] = valFields . head . valFields $ bs
                          in B.pack . map (fromIntegral . wrd_) . arrList $ vs

               --bits3 (Value {valName = "Bits3", valFields = bs}) = bits bs
               --bits4 (Value {valName = "Bits4", valFields = bs}) = bits bs
               bits8 (Value {valName = "Bits8", valFields = bs}) = bits bs
               --bits7 (Value {valName = "Bits7", valFields = bs}) = bits bs
               bits11 (Value {valName = "Bits11", valFields = bs}) = bits bs
               bits23 (Value {valName = "Bits23", valFields = bs}) = bits bs
               bits52 (Value {valName = "Bits52", valFields = bs}) = bits bs
               bits = map bit
               bit v = let [b] = valBits v in b
               -- floatVal (Value {valName = "IEEE_754_binary32"
               --                 ,valFields = [Value {valBits = [signVal]}
               --                              ,Value {valName = "MostSignificantFirst", valFields = [expVal]}
               --                              ,Value {valName = "MostSignificantFirst", valFields = [Value {valName = "Bits23"
               --                                                                                           ,valFields = [frac1,frac2,frac3]}]}]})
               --   = ieee signVal [bits8 expVal] [bits7 frac1,bits8 frac2,bits8 frac3] 127

               -- doubleVal (Value {valName = "IEEE_754_binary64"
               --                  ,valFields = [Value {valBits = [signVal]}
               --                               ,Value {valName = "MostSignificantFirst"
               --                                      ,valFields = [Value {valName = "Bits11"
               --                                                          ,valFields = [expVal1,expVal2]}]}
               --                               ,Value {valName = "MostSignificantFirst"
               --                                      ,valFields = [Value {valName = "Bits52"
               --                                                          ,valFields = [frac1,frac2,frac3,frac4,frac5,frac6,frac7]}]}]})
               --   = ieee signVal [bits3 expVal1,bits8 expVal2] [bits4 frac1,bits8 frac2,bits8 frac3,bits8 frac4,bits8 frac5,bits8 frac6,bits8 frac7] 1023

               floatVal (Value {valName = "IEEE_754_binary32"
                               ,valFields = [Value {valBits = [signVal]}
                                            ,msb -> expVal
                                            ,msb -> frac]})
                 = ieee signVal [bits8 expVal] [bits23 frac] 127

               doubleVal (Value {valName = "IEEE_754_binary64"
                                ,valFields = [Value {valBits = [signVal]}
                                            ,msb -> expVal
                                            ,msb -> frac]})
                 = ieee signVal [bits11 expVal] [bits52 frac] 1023

               ieee sign exps fracs expOff =
                   let signV = fromIntegral $ fromEnum sign
                       expV = fromIntegral $ bitsVal $ concat exps
                       fracBits = concat $ [True] : fracs
                       fracV = fromIntegral $ bitsVal fracBits
                       val = ((-1)**signV)*(fracV / (2 ^ (length fracBits -1)))*(2**(expV-expOff))
                   in val
               msb (Value {valName = "MostSignificantFirst", valFields = [v]}) = v

-- MSF bitsVal
-- bitsVal [True,False,True,False]
-- > 10
bitsVal :: [Bool] -> Int
bitsVal = fst . foldl (\(t,e) n -> (t+fromEnum n *2^e,e+1)) (0::Int,0::Int) . reverse

-- Used to match any type
data Any deriving (Generic,Model)

tAny :: AbsType
tAny = absType (Proxy:: Proxy Any)

match :: Type AbsRef -> Type AbsRef -> Bool
match (TypeApp f1 a1) (TypeApp f2 a2) = match f1 f2 && match a1 a2
match t1 t2 | t2 == tAny = True
            | otherwise = t1 == t2

-- arr_ f elems = hsep $ text "Array" : [prettyList f elems]
--arr_ :: Pretty b => (a -> b) -> [a] -> Doc
--arr_ f elems = hsep [prettyList_ f elems]
arr_ :: (a -> Doc) -> [a] -> Doc
arr_ = prettyList_

-- prettyList_ :: Pretty b => (a -> b) -> [a] -> Doc
-- prettyList_ f vs = pPrint $ map f vs
prettyList_ :: (a -> Doc) -> [a] -> Doc
prettyList_ f vs = prettyList $ map f vs

prettyTuple_ :: (a -> Doc) -> [a] -> Doc
prettyTuple_ f vs = prettyTuple $ map f vs

-- haskell Style
-- prettySeq sep1 sep2 f elems = char sep1 <> (hcat . intersperse (text ", ") . map f $ elems) <> char sep2
-- prettySeq sep1 sep2 f elems = char sep1 <> (hcat . intersperse (text ", ") . map f $ elems) <> char sep2