{-# LANGUAGE OverloadedStrings #-}
module Reason.Common where
import Control.Monad.RWS
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Char as C
import qualified Data.Text.Lazy as LT
import Formatting hiding (text)
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
data Options = Options
{ fieldLabelModifier :: Text -> Text
}
defaultOptions :: Options
defaultOptions = Options {fieldLabelModifier = id}
cr :: Format r r
cr = now "\n"
mintercalate
:: Monoid m
=> m -> [m] -> m
mintercalate _ [] = mempty
mintercalate _ [x] = x
mintercalate seperator (x:xs) = x <> seperator <> mintercalate seperator xs
pprinter :: Doc -> Text
pprinter = LT.toStrict . displayT . renderPretty 0.4 100
stext :: Data.Text.Text -> Doc
stext = text . LT.fromStrict
stextLower :: Data.Text.Text -> Doc
stextLower = text . LT.fromStrict . (\x -> C.toLower (T.head x) `T.cons` T.tail x)
stextLowerSuffix :: Data.Text.Text -> Data.Text.Text -> Doc
stextLowerSuffix suffix = text . LT.fromStrict . (\x -> C.toLower (T.head x) `T.cons` T.tail x `T.append` suffix)
stextSuffix :: Data.Text.Text -> Data.Text.Text -> Doc
stextSuffix suffix = text . LT.fromStrict . (`T.append` suffix)
spaceparens :: Doc -> Doc
spaceparens doc = "(" <+> doc <+> ")"
newlineparens :: Doc -> Doc
newlineparens doc = "(" <> doc <$$> ")"
emptyline :: Doc
emptyline = nest minBound linebreak
(<$+$>) :: Doc -> Doc -> Doc
l <$+$> r = l <> emptyline <$$> r
type RenderM = RWS Options (Set Text
, [Text]
) (Maybe Text)
require :: Text -> RenderM ()
require dep = tell (S.singleton dep, [])
collectDeclaration :: RenderM Doc -> RenderM ()
collectDeclaration =
mapRWS ((\(defn, s, (imports, _)) -> ((), s, (imports, [pprinter defn]))))
squarebracks :: Doc -> Doc
squarebracks doc = "[" <+> doc <+> "]"
pair :: Doc -> Doc -> Doc
pair l r = spaceparens $ l <> comma <+> r
reservedKeywords :: [T.Text]
reservedKeywords = ["and","as","assertbegin","constraint","done","downto","end"
,"exception","external","for","fun","function","functor","in","include"
,"inherit","initializer","let","match","method","module","mutable","of"
,"open","or","struct","to","true","try","type","virtual","while","with"]
maybeReserved :: T.Text -> T.Text
maybeReserved name | name `elem` reservedKeywords = name <> "_"
| otherwise = name