content: {-# LANGUAGE PatternGuards #-}
  
  --------------------------------------------------------------------
  -- |
  -- Copyright :  (c) Dan Doel 2013
  -- License   :  BSD2
  -- Maintainer:  Dan Doel <dan.doel@gmail.com>
  -- Stability :  experimental
  -- Portability: non-portable
  --
  -- Tools for pretty-printing 'Core' expressions.
  --------------------------------------------------------------------
  
  module Ermine.Pretty.Core
   ( prettyCore
   , prettyHardCore
   , prettyId
   ) where
  
  import Bound
  import Control.Lens
  import Control.Applicative
  import Data.Bifunctor
  import Data.Monoid
  import Data.Text.Lens hiding (text)
  import Data.Traversable
  import Data.Word
  import Ermine.Pretty
  import Ermine.Pretty.Global
  import Ermine.Pretty.Literal
  import Ermine.Pretty.Type
  import Ermine.Syntax.Convention
  import Ermine.Syntax.Core
  import Ermine.Syntax.Global
  import Ermine.Syntax.Head
  import Ermine.Syntax.Id
  import Ermine.Syntax.Name
  
  -- | Pretty print JavaLike FFI descrptions
  prettyJavaLike :: JavaLike -> Doc
  prettyJavaLike (Method _st _cn _mn _args) = text "method{..}" -- TODO
  prettyJavaLike (Constructor _cn _args)    = text "constructor{..}" -- TODO
  prettyJavaLike (Value _st _cn _fn)        = text "value{..}" -- TODO
  
  prettyForeign :: Foreign -> Doc
  prettyForeign (JavaLike j) = prettyJavaLike j
  prettyForeign (Unknown s)  = text $ "unknown{" ++ show s ++ "}"
  
  -- | Pretty print a 'HardCore' expression.
  prettyHardCore :: Int -> HardCore -> Doc
  prettyHardCore _ (Super   i)     = text $ "super{" ++ show i ++ "}"
  prettyHardCore _ (Slot    i)     = text $ "slot{"  ++ show i ++ "}"
  prettyHardCore _ (Lit     l)     = prettyLiteral l
  prettyHardCore _ (Foreign f)     = prettyForeign f
  prettyHardCore n (Error   s)     = parensIf (n>10) . text $ "error " ++ show s
  prettyHardCore _ (Id      g)     = prettyId g
  
  prettyId :: Id -> Doc
  prettyId (GlobalId g)   = prettyGlobal g
  prettyId (InstanceId h) = prettyHead h
  
  prettyHead :: Head -> Doc
  prettyHead i = text ("instance{" ++ (i^.headClass.name.unpacked))
       <+> hsep ((prettyType ?? repeat "_" ?? 1000) . bimap (const "_") (const "_")
             <$> i^.headTypeArgs)
        <> text "}"
  
  -- | Pretty print a 'HardCore' expression.
  prettyCore :: Applicative f
             => [String] -> Int -> (a -> Int -> f Doc) -> Core Convention a -> f Doc
  prettyCore _  prec k (Var v) = k v prec
  prettyCore _  prec _ (HardCore h) = pure $ prettyHardCore prec h
  prettyCore vs prec k (Data cc tg g fs) =
    parensIf (prec > 10) . coreData cc tg g <$> traverse (prettyCore vs 11 k) fs
  prettyCore vs _    k (Prim cc r g fs) =
    corePrim cc r g <$> traverse (prettyCore vs 11 k) fs
  prettyCore vs prec k (App _ f x) =
    (\df dx -> parensIf (prec>10) $ df <+> dx)
      <$> prettyCore vs 10 k f <*> prettyCore vs 11 k x
  prettyCore vs prec k (Lam cc (Scope e)) =
    coreLam cc prec ws <$> prettyCore rest (-1) k' e
   where
   (ws, rest) = first (fmap text) $ splitAt (length cc) vs
   k' (B i) _ = pure $ ws !! fromIntegral i
   k' (F c) p = prettyCore rest p k c
  prettyCore (v:vs) prec k (Case e m d) =
    coreCase dv prec
      <$> prettyCore vs (-1) k e
      <*> branches
      <*> traverse (prettyCore vs (-1) l . unscope) d
   where
   l (B _) _ = pure dv
   l (F c) p = prettyCore vs p k c
   dv = text v
   branches = for (itoList m) $ \(tg, Match cc g (Scope b)) ->
     let (ws,rest) = first (fmap text) $ splitAt (length cc) vs
         k' (B 0) _ = pure dv
         k' (B i) _ = pure $ ws !! fromIntegral (i-1)
         k' (F c) p = prettyCore rest p k c
      in (\bd -> nest 2 $ coreData cc tg g ws <+> text "->" <+> bd)
            <$> prettyCore rest (-1) k' b
  
  prettyCore vs prec k (Let bs e) = h <$> traverse pc bs <*> pc e
   where
   pc = prettyCore rest (-1) k' . unscope
   n = length bs
   (ws,rest) = first (fmap text) $ splitAt n vs
   k' (B i) _ = pure $ ws !! fromIntegral i
   k' (F c) p = prettyCore rest p k c
   eq l r = l <+> text "=" <+> r
   h bds ed = parensIf (prec>=0) . nest 2 $
                text "let" <+> block (zipWith eq ws bds) <+> text "in" <+> ed
  prettyCore vs _ k (Dict sups sls) =
    (\xs ys -> text "dict" <> block [text "supers" `eq` block xs, text "slots" `eq` block (zipWith eq slotNames ys)])
      <$> traverse (prettyCore vs 0 k) sups
      <*> traverse (prettyCore rest 0 k' . unscope) sls
   where
    (slotNames,rest) = first (fmap text) $ splitAt (length sls) vs
    eq l r = l <+> text "=" <+> r
    k' (B i) _ = pure $ slotNames !! fromIntegral i
    k' (F c) p = prettyCore rest p k c
  prettyCore [] _ _ _ = error "panic: prettyCore ran out of variable names"
  
  -- \{a,b} [C,C]->C body
  coreLam :: [Convention] -> Int -> [Doc] -> Doc -> Doc
  coreLam cc prec ws e = parensIf (prec>=0) $
    text "\\" <> encloseSep lbrace rbrace comma ws <+> encloseSep lbracket rbracket comma (text.show<$>cc) <> text "->" <+> e
  
  -- Nothing<0,[]>
  -- Just<1,[C]> a
  coreData :: [Convention] -> Word64 -> Global -> [Doc] -> Doc
  coreData cc tg g fds = text (g^.name.unpacked) <> text "<" <> int (fromIntegral tg) <> text "," <> text (show cc) <> text ">" <+> hsep fds
  
  corePrim :: [Convention] -> Convention -> Global -> [Doc] -> Doc
  corePrim cc tg g fds = text (g^.name.unpacked) <> text "<" <> text (show tg) <> text "," <> text (show cc) <> text ">" <+> hsep fds
  
  coreCase :: Doc -> Int -> Doc -> [Doc] -> Maybe Doc -> Doc
  coreCase dv prec de dbs mdd = parensIf (prec>=0) $
    nest 2 $ text "case" <+> de <+> text "of" <+> dv <$$> coreBlock dbs'
   where dbs' | Just dd <- mdd = dbs ++ [text "_ ->" <+> dd]
              | otherwise      = dbs
  
  coreBlock :: [Doc] -> Doc
  coreBlock [    ] = text "{}"
  coreBlock (d:ds) = vsep (lbrace <+> d : map (semi <+>) ds) <> line <> rbrace
  