



{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE GADTs  #-}


{-# LANGUAGE DataKinds  #-}
{-# LANGUAGE CPP  #-}



-- ghc options

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
-- {-# OPTIONS_GHC -fno-warn-name-shadowing #-}


{-# OPTIONS_GHC -fno-warn-orphans #-}
-- {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-- {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
-- {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-- {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-- {-# OPTIONS_GHC -fno-warn-name-shadowing #-}




-- |
-- Copyright :  (c) Andreas Reuleaux 2015
-- License   :  BSD2
-- Maintainer:  Andreas Reuleaux <rx@a-rx.info>
-- Stability :  experimental
-- Portability: non-portable
--
-- This module provides pretty printing functionality for Pire's
-- abstract and concrete syntax: token


module Pire.Pretty.Token where




import Pire.Syntax.Token

import Pire.Pretty.Common
import Pire.Pretty.Ws ()


import Text.PrettyPrint as TPP




-- import Control.Monad.Error
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(7,10,3,0)
-- ghc >= 7.10.3
#else
-- older ghc versions, but MIN_VERSION_GLASGOW_HASKELL defined
#endif
#else
-- MIN_VERSION_GLASGOW_HASKELL not even defined yet (ghc <= 7.8.x)
import Control.Applicative
#endif








-- instance Disp t => Disp (Token ty t) where
--   -- shorter?
--   disp (LamTok lam ws) = (<>) <$> disp lam <*> disp ws
--   disp (Dot txt ws) = (<>) <$> disp txt <*> disp ws
--   disp (LetTok txt ws) = (<>) <$> disp txt <*> disp ws

--   disp (BracketOpen txt ws) = (<>) <$> disp txt <*> disp ws
--   disp (BracketClose txt ws) = (<>) <$> disp txt <*> disp ws

--   disp (ParenOpen txt ws) = (<>) <$> disp txt <*> disp ws
--   disp (ParenClose txt ws) = (<>) <$> disp txt <*> disp ws



-- but can continue to define them separately as well...
-- but have to use either one: cannot use a combination of the above with some instance decls below


instance Disp t => Disp (Token 'LamTokTy t) where
  disp (LamTok bo ws) = (<>) <$> disp bo <*> disp ws


instance Disp t => Disp (Token 'DotTy t) where
  disp (Dot bo ws) = (<>) <$> disp bo <*> disp ws


instance Disp t => Disp (Token 'LetTokTy t) where
  disp (LetTok bo ws) = (<>) <$> disp bo <*> disp ws


                         
instance Disp t => Disp (Token 'BracketOpenTy t) where
  disp (BracketOpen bo ws) = (<>) <$> disp bo <*> disp ws

instance Disp t => Disp (Token 'BracketCloseTy t) where
  disp (BracketClose bc ws) = (<>) <$> disp bc <*> disp ws


                         
instance Disp t => Disp (Token 'ParenOpenTy t) where
  disp (ParenOpen bo ws) = (<>) <$> disp bo <*> disp ws

instance Disp t => Disp (Token 'ParenCloseTy t) where
  disp (ParenClose bc ws) = (<>) <$> disp bc <*> disp ws

                         

                         

                         
instance Disp t => Disp (Token 'BraceOpenTy t) where
  disp (BraceOpen bo ws) = (<>) <$> disp bo <*> disp ws

instance Disp t => Disp (Token 'BraceCloseTy t) where
  disp (BraceClose bc ws) = (<>) <$> disp bc <*> disp ws

-- the maybe's
                         
instance Disp t => Disp (Maybe (Token 'BraceOpenTy t)) where
  disp (Just bo) = disp bo
  disp Nothing = return TPP.empty


instance Disp t => Disp (Maybe (Token 'BraceCloseTy t)) where
  disp (Just bo) = disp bo
  disp Nothing = return TPP.empty


                         

  


instance Disp t => Disp (Token 'InTy t) where
  disp (In in' ws) = (<>) <$> disp in' <*> disp ws



instance Disp t => Disp (Token 'ColonTy t) where
  disp (Colon col ws) = (<>) <$> disp col <*> disp ws


instance Disp t => Disp (Token 'EqualTy t) where
  disp (Equal eq ws) = (<>) <$> disp eq <*> disp ws


instance Disp t => Disp (Token 'SubstTokTy t) where
  disp (SubstTok s ws) = (<>) <$> disp s <*> disp ws


instance Disp t => Disp (Token 'ContraTokTy t) where
  disp (ContraTok c ws) = (<>) <$> disp c <*> disp ws


instance Disp t => Disp (Token 'ByTy t) where
  disp (By b ws) = (<>) <$> disp b <*> disp ws


instance Disp t => Disp (Token 'ArrowTy t) where
  disp (Arrow arr ws) = (<>) <$> disp arr <*> disp ws

instance Disp t => Disp (Token 'IfTokTy t) where
  disp (IfTok if' ws) = (<>) <$> disp if' <*> disp ws


instance Disp t => Disp (Token 'ThenTokTy t) where
  disp (ThenTok then' ws) = (<>) <$> disp then' <*> disp ws


instance Disp t => Disp (Token 'ElseTokTy t) where
  disp (ElseTok else' ws) = (<>) <$> disp else' <*> disp ws


instance Disp t => Disp (Token 'VBarTy t) where
  disp (VBar vb ws) = (<>) <$> disp vb <*> disp ws


-- disp (Where ws) = do  { dws <- disp ws ; return $ text "where" <> dws }

instance Disp t => Disp (Token 'WhereTy t) where
  disp (Where w ws) = (<>) <$> disp w <*> disp ws


instance Disp t => Disp (Token 'DataTokTy t) where
  disp (DataTok w ws) = (<>) <$> disp w <*> disp ws



instance Disp t => Disp (Token 'OfTy t) where
  disp (Of o ws) = (<>) <$> disp o <*> disp ws

-- + Maybe token

instance Disp t => Disp (Maybe (Token 'OfTy t)) where
  disp Nothing = return TPP.empty
  disp (Just of') = disp of'




instance Disp t => Disp (Token 'CaseTokTy t) where
  disp (CaseTok c ws) = (<>) <$> disp c <*> disp ws


instance Disp t => Disp (Token 'PcaseTokTy t) where
  disp (PcaseTok c ws) = (<>) <$> disp c <*> disp ws


instance Disp t => Disp (Token 'CommaTy t) where
  disp (Comma c ws) = (<>) <$> disp c <*> disp ws


instance Disp t => Disp (Token 'ModuleTokTy t) where
  disp (ModuleTok m ws) = (<>) <$> disp m <*> disp ws




                          
instance Disp t => Disp (Token 'SemiColonTy t) where
  disp (SemiColon sem ws) = (<>) <$> disp sem <*> disp ws

instance Disp t => Disp (Maybe (Token 'SemiColonTy t)) where
  disp (Just semicolon) = disp semicolon
  disp Nothing = return TPP.empty




instance Disp t => Disp (Token 'ImportTokTy t) where
  disp (ImportTok i ws) = (<>) <$> disp i <*> disp ws

