{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}

-- | All types.

module HIndent.Types
  (Printer(..)
  ,PrintState(..)
  ,Config(..)
  ,readExtension
  ,defaultConfig
  ,NodeInfo(..)
  ,NodeComment(..)
  ,SomeComment(..)
  ) where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.State.Strict (MonadState(..),StateT)
import           Control.Monad.Trans.Maybe
import           Data.ByteString.Builder
import           Data.Functor.Identity
import           Data.Int (Int64)
import           Data.Maybe
import           Data.Yaml (FromJSON(..))
import qualified Data.Yaml as Y
import           Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse)

-- | A pretty printing monad.
newtype Printer a =
  Printer {Printer a -> StateT PrintState (MaybeT Identity) a
runPrinter :: StateT PrintState (MaybeT Identity) a}
  deriving (Functor Printer
a -> Printer a
Functor Printer
-> (forall a. a -> Printer a)
-> (forall a b. Printer (a -> b) -> Printer a -> Printer b)
-> (forall a b c.
    (a -> b -> c) -> Printer a -> Printer b -> Printer c)
-> (forall a b. Printer a -> Printer b -> Printer b)
-> (forall a b. Printer a -> Printer b -> Printer a)
-> Applicative Printer
Printer a -> Printer b -> Printer b
Printer a -> Printer b -> Printer a
Printer (a -> b) -> Printer a -> Printer b
(a -> b -> c) -> Printer a -> Printer b -> Printer c
forall a. a -> Printer a
forall a b. Printer a -> Printer b -> Printer a
forall a b. Printer a -> Printer b -> Printer b
forall a b. Printer (a -> b) -> Printer a -> Printer b
forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Printer a -> Printer b -> Printer a
$c<* :: forall a b. Printer a -> Printer b -> Printer a
*> :: Printer a -> Printer b -> Printer b
$c*> :: forall a b. Printer a -> Printer b -> Printer b
liftA2 :: (a -> b -> c) -> Printer a -> Printer b -> Printer c
$cliftA2 :: forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
<*> :: Printer (a -> b) -> Printer a -> Printer b
$c<*> :: forall a b. Printer (a -> b) -> Printer a -> Printer b
pure :: a -> Printer a
$cpure :: forall a. a -> Printer a
$cp1Applicative :: Functor Printer
Applicative,Applicative Printer
a -> Printer a
Applicative Printer
-> (forall a b. Printer a -> (a -> Printer b) -> Printer b)
-> (forall a b. Printer a -> Printer b -> Printer b)
-> (forall a. a -> Printer a)
-> Monad Printer
Printer a -> (a -> Printer b) -> Printer b
Printer a -> Printer b -> Printer b
forall a. a -> Printer a
forall a b. Printer a -> Printer b -> Printer b
forall a b. Printer a -> (a -> Printer b) -> Printer b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Printer a
$creturn :: forall a. a -> Printer a
>> :: Printer a -> Printer b -> Printer b
$c>> :: forall a b. Printer a -> Printer b -> Printer b
>>= :: Printer a -> (a -> Printer b) -> Printer b
$c>>= :: forall a b. Printer a -> (a -> Printer b) -> Printer b
$cp1Monad :: Applicative Printer
Monad,a -> Printer b -> Printer a
(a -> b) -> Printer a -> Printer b
(forall a b. (a -> b) -> Printer a -> Printer b)
-> (forall a b. a -> Printer b -> Printer a) -> Functor Printer
forall a b. a -> Printer b -> Printer a
forall a b. (a -> b) -> Printer a -> Printer b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Printer b -> Printer a
$c<$ :: forall a b. a -> Printer b -> Printer a
fmap :: (a -> b) -> Printer a -> Printer b
$cfmap :: forall a b. (a -> b) -> Printer a -> Printer b
Functor,MonadState PrintState,Monad Printer
Alternative Printer
Printer a
Alternative Printer
-> Monad Printer
-> (forall a. Printer a)
-> (forall a. Printer a -> Printer a -> Printer a)
-> MonadPlus Printer
Printer a -> Printer a -> Printer a
forall a. Printer a
forall a. Printer a -> Printer a -> Printer a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: Printer a -> Printer a -> Printer a
$cmplus :: forall a. Printer a -> Printer a -> Printer a
mzero :: Printer a
$cmzero :: forall a. Printer a
$cp2MonadPlus :: Monad Printer
$cp1MonadPlus :: Alternative Printer
MonadPlus,Applicative Printer
Printer a
Applicative Printer
-> (forall a. Printer a)
-> (forall a. Printer a -> Printer a -> Printer a)
-> (forall a. Printer a -> Printer [a])
-> (forall a. Printer a -> Printer [a])
-> Alternative Printer
Printer a -> Printer a -> Printer a
Printer a -> Printer [a]
Printer a -> Printer [a]
forall a. Printer a
forall a. Printer a -> Printer [a]
forall a. Printer a -> Printer a -> Printer a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: Printer a -> Printer [a]
$cmany :: forall a. Printer a -> Printer [a]
some :: Printer a -> Printer [a]
$csome :: forall a. Printer a -> Printer [a]
<|> :: Printer a -> Printer a -> Printer a
$c<|> :: forall a. Printer a -> Printer a -> Printer a
empty :: Printer a
$cempty :: forall a. Printer a
$cp1Alternative :: Applicative Printer
Alternative)

-- | The state of the pretty printer.
data PrintState = PrintState
  { PrintState -> Int64
psIndentLevel :: !Int64
    -- ^ Current indentation level, i.e. every time there's a
    -- new-line, output this many spaces.
  , PrintState -> Builder
psOutput :: !Builder
    -- ^ The current output bytestring builder.
  , PrintState -> Bool
psNewline :: !Bool
    -- ^ Just outputted a newline?
  , PrintState -> Int64
psColumn :: !Int64
    -- ^ Current column.
  , PrintState -> Int64
psLine :: !Int64
    -- ^ Current line number.
  , PrintState -> Config
psConfig :: !Config
    -- ^ Configuration of max colums and indentation style.
  , PrintState -> Bool
psInsideCase :: !Bool
    -- ^ Whether we're in a case statement, used for Rhs printing.
  , PrintState -> Bool
psFitOnOneLine :: !Bool
    -- ^ Bail out if we need to print beyond the current line or
    -- the maximum column.
  , PrintState -> Bool
psEolComment :: !Bool
  }

-- | Configurations shared among the different styles. Styles may pay
-- attention to or completely disregard this configuration.
data Config = Config
    { Config -> Int64
configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally.
    , Config -> Int64
configIndentSpaces :: !Int64 -- ^ How many spaces to indent?
    , Config -> Bool
configTrailingNewline :: !Bool -- ^ End with a newline.
    , Config -> Bool
configSortImports :: !Bool -- ^ Sort imports in groups.
    , Config -> [String]
configLineBreaks :: [String] -- ^ Break line when meets these operators.
    , Config -> [Extension]
configExtensions :: [Extension]
      -- ^ Extra language extensions enabled by default.
    }

-- | Parse an extension.

#if __GLASGOW_HASKELL__ >= 808
readExtension :: (Monad m, MonadFail m) => String -> m Extension
#else
readExtension :: Monad m => String -> m Extension
#endif
readExtension :: String -> m Extension
readExtension String
x =
  case String -> Extension
classifyExtension String
x -- Foo
       of
    UnknownExtension String
_ -> String -> m Extension
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown extension: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
    Extension
x' -> Extension -> m Extension
forall (m :: * -> *) a. Monad m => a -> m a
return Extension
x'

instance FromJSON Config where
  parseJSON :: Value -> Parser Config
parseJSON (Y.Object Object
v) =
    Int64 -> Int64 -> Bool -> Bool -> [String] -> [Extension] -> Config
Config (Int64
 -> Int64 -> Bool -> Bool -> [String] -> [Extension] -> Config)
-> Parser Int64
-> Parser
     (Int64 -> Bool -> Bool -> [String] -> [Extension] -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (Maybe Int64 -> Int64) -> Parser (Maybe Int64) -> Parser Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe (Config -> Int64
configMaxColumns Config
defaultConfig))
        (Object
v Object -> Text -> Parser (Maybe Int64)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Y..:? Text
"line-length") Parser (Int64 -> Bool -> Bool -> [String] -> [Extension] -> Config)
-> Parser Int64
-> Parser (Bool -> Bool -> [String] -> [Extension] -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      (Maybe Int64 -> Int64) -> Parser (Maybe Int64) -> Parser Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe (Config -> Int64
configIndentSpaces Config
defaultConfig))
        (Object
v Object -> Text -> Parser (Maybe Int64)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Y..:? Text
"indent-size" Parser (Maybe Int64)
-> Parser (Maybe Int64) -> Parser (Maybe Int64)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
v Object -> Text -> Parser (Maybe Int64)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Y..:? Text
"tab-size") Parser (Bool -> Bool -> [String] -> [Extension] -> Config)
-> Parser Bool
-> Parser (Bool -> [String] -> [Extension] -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      (Maybe Bool -> Bool) -> Parser (Maybe Bool) -> Parser Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Config -> Bool
configTrailingNewline Config
defaultConfig))
        (Object
v Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Y..:? Text
"force-trailing-newline") Parser (Bool -> [String] -> [Extension] -> Config)
-> Parser Bool -> Parser ([String] -> [Extension] -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      (Maybe Bool -> Bool) -> Parser (Maybe Bool) -> Parser Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Config -> Bool
configSortImports Config
defaultConfig))
        (Object
v Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Y..:? Text
"sort-imports") Parser ([String] -> [Extension] -> Config)
-> Parser [String] -> Parser ([Extension] -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      (Maybe [String] -> [String])
-> Parser (Maybe [String]) -> Parser [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ([String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe (Config -> [String]
configLineBreaks Config
defaultConfig))
        (Object
v Object -> Text -> Parser (Maybe [String])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Y..:? Text
"line-breaks") Parser ([Extension] -> Config)
-> Parser [Extension] -> Parser Config
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      ((String -> Parser Extension) -> [String] -> Parser [Extension]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Parser Extension
forall (m :: * -> *).
(Monad m, MonadFail m) =>
String -> m Extension
readExtension
        ([String] -> Parser [Extension])
-> Parser [String] -> Parser [Extension]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Maybe [String] -> [String])
-> Parser (Maybe [String]) -> Parser [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe []) (Object
v Object -> Text -> Parser (Maybe [String])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Y..:? Text
"extensions"))
  parseJSON Value
_ = String -> Parser Config
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected Object for Config value"

-- | Default style configuration.
defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
    Config :: Int64 -> Int64 -> Bool -> Bool -> [String] -> [Extension] -> Config
Config
    { configMaxColumns :: Int64
configMaxColumns = Int64
80
    , configIndentSpaces :: Int64
configIndentSpaces = Int64
2
    , configTrailingNewline :: Bool
configTrailingNewline = Bool
True
    , configSortImports :: Bool
configSortImports = Bool
True
    , configLineBreaks :: [String]
configLineBreaks = []
    , configExtensions :: [Extension]
configExtensions = []
    }

-- | Some comment to print.
data SomeComment
  = EndOfLine String
  | MultiLine String
  deriving (Int -> SomeComment -> String -> String
[SomeComment] -> String -> String
SomeComment -> String
(Int -> SomeComment -> String -> String)
-> (SomeComment -> String)
-> ([SomeComment] -> String -> String)
-> Show SomeComment
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SomeComment] -> String -> String
$cshowList :: [SomeComment] -> String -> String
show :: SomeComment -> String
$cshow :: SomeComment -> String
showsPrec :: Int -> SomeComment -> String -> String
$cshowsPrec :: Int -> SomeComment -> String -> String
Show, Eq SomeComment
Eq SomeComment
-> (SomeComment -> SomeComment -> Ordering)
-> (SomeComment -> SomeComment -> Bool)
-> (SomeComment -> SomeComment -> Bool)
-> (SomeComment -> SomeComment -> Bool)
-> (SomeComment -> SomeComment -> Bool)
-> (SomeComment -> SomeComment -> SomeComment)
-> (SomeComment -> SomeComment -> SomeComment)
-> Ord SomeComment
SomeComment -> SomeComment -> Bool
SomeComment -> SomeComment -> Ordering
SomeComment -> SomeComment -> SomeComment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SomeComment -> SomeComment -> SomeComment
$cmin :: SomeComment -> SomeComment -> SomeComment
max :: SomeComment -> SomeComment -> SomeComment
$cmax :: SomeComment -> SomeComment -> SomeComment
>= :: SomeComment -> SomeComment -> Bool
$c>= :: SomeComment -> SomeComment -> Bool
> :: SomeComment -> SomeComment -> Bool
$c> :: SomeComment -> SomeComment -> Bool
<= :: SomeComment -> SomeComment -> Bool
$c<= :: SomeComment -> SomeComment -> Bool
< :: SomeComment -> SomeComment -> Bool
$c< :: SomeComment -> SomeComment -> Bool
compare :: SomeComment -> SomeComment -> Ordering
$ccompare :: SomeComment -> SomeComment -> Ordering
$cp1Ord :: Eq SomeComment
Ord, SomeComment -> SomeComment -> Bool
(SomeComment -> SomeComment -> Bool)
-> (SomeComment -> SomeComment -> Bool) -> Eq SomeComment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SomeComment -> SomeComment -> Bool
$c/= :: SomeComment -> SomeComment -> Bool
== :: SomeComment -> SomeComment -> Bool
$c== :: SomeComment -> SomeComment -> Bool
Eq)

-- | Comment associated with a node.
-- 'SrcSpan' is the original source span of the comment.
data NodeComment
  = CommentSameLine SrcSpan SomeComment
  | CommentAfterLine SrcSpan SomeComment
  | CommentBeforeLine SrcSpan SomeComment
  deriving (Int -> NodeComment -> String -> String
[NodeComment] -> String -> String
NodeComment -> String
(Int -> NodeComment -> String -> String)
-> (NodeComment -> String)
-> ([NodeComment] -> String -> String)
-> Show NodeComment
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [NodeComment] -> String -> String
$cshowList :: [NodeComment] -> String -> String
show :: NodeComment -> String
$cshow :: NodeComment -> String
showsPrec :: Int -> NodeComment -> String -> String
$cshowsPrec :: Int -> NodeComment -> String -> String
Show, Eq NodeComment
Eq NodeComment
-> (NodeComment -> NodeComment -> Ordering)
-> (NodeComment -> NodeComment -> Bool)
-> (NodeComment -> NodeComment -> Bool)
-> (NodeComment -> NodeComment -> Bool)
-> (NodeComment -> NodeComment -> Bool)
-> (NodeComment -> NodeComment -> NodeComment)
-> (NodeComment -> NodeComment -> NodeComment)
-> Ord NodeComment
NodeComment -> NodeComment -> Bool
NodeComment -> NodeComment -> Ordering
NodeComment -> NodeComment -> NodeComment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NodeComment -> NodeComment -> NodeComment
$cmin :: NodeComment -> NodeComment -> NodeComment
max :: NodeComment -> NodeComment -> NodeComment
$cmax :: NodeComment -> NodeComment -> NodeComment
>= :: NodeComment -> NodeComment -> Bool
$c>= :: NodeComment -> NodeComment -> Bool
> :: NodeComment -> NodeComment -> Bool
$c> :: NodeComment -> NodeComment -> Bool
<= :: NodeComment -> NodeComment -> Bool
$c<= :: NodeComment -> NodeComment -> Bool
< :: NodeComment -> NodeComment -> Bool
$c< :: NodeComment -> NodeComment -> Bool
compare :: NodeComment -> NodeComment -> Ordering
$ccompare :: NodeComment -> NodeComment -> Ordering
$cp1Ord :: Eq NodeComment
Ord, NodeComment -> NodeComment -> Bool
(NodeComment -> NodeComment -> Bool)
-> (NodeComment -> NodeComment -> Bool) -> Eq NodeComment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeComment -> NodeComment -> Bool
$c/= :: NodeComment -> NodeComment -> Bool
== :: NodeComment -> NodeComment -> Bool
$c== :: NodeComment -> NodeComment -> Bool
Eq)

-- | Information for each node in the AST.
data NodeInfo = NodeInfo
  { NodeInfo -> SrcSpanInfo
nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser.
  , NodeInfo -> [NodeComment]
nodeInfoComments :: ![NodeComment] -- ^ Comments attached to this node.
  }
instance Show NodeInfo where
  show :: NodeInfo -> String
show (NodeInfo SrcSpanInfo
_ []) = String
""
  show (NodeInfo SrcSpanInfo
_ [NodeComment]
s) =
    String
"{- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [NodeComment] -> String
forall a. Show a => a -> String
show [NodeComment]
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -}"