{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Data.Aeson.Schema.CodeGenM
( Declaration (..)
, Code
, CodeGenM (..)
, renderDeclaration
, codeGenNewName
, genRecord
, Options(..)
, defaultOptions
, askOpts
, askEnv
) where
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.RWS.Lazy (MonadReader (..), MonadState (..),
MonadWriter (..), RWST (..))
import qualified Control.Monad.Trans.Class as MT
import Data.Data (Data, Typeable)
import Data.Function (on)
import qualified Data.HashSet as HS
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import qualified Data.Text as T
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
data Declaration = Declaration Dec (Maybe Text)
| Comment Text
deriving (Show, Eq, Typeable, Data)
renderDeclaration :: Declaration -> Text
renderDeclaration (Declaration _ (Just text)) = text
renderDeclaration (Declaration dec Nothing) = T.pack (pprint dec)
renderDeclaration (Comment comment) = T.unlines $ map (\line -> "-- " <> line) $ T.lines comment
type Code = [Declaration]
type StringSet = HS.HashSet String
codeGenNewName :: String -> StringSet -> (Name, StringSet)
codeGenNewName s used = (Name (mkOccName free) NameS, HS.insert free used)
where
free = head $ dropWhile (`HS.member` used) $ (if validName s then (s:) else id) $ map (\i -> s ++ "_" ++ show i) ([1..] :: [Int])
haskellKeywords = HS.fromList
[ "as", "case", "of", "class", "data", "data family", "data instance"
, "default", "deriving", "deriving instance", "do", "forall", "foreign"
, "hiding", "if", "then", "else", "import", "infix", "infixl", "infixr"
, "instance", "let", "in", "mdo", "module", "newtype", "proc"
, "qualified", "rec", "type", "type family", "type instance", "where"
]
validName n = not (n `elem` ["", "_"] || n `HS.member` haskellKeywords)
newtype CodeGenM s a = CodeGenM
{ unCodeGenM :: RWST (Options, s) Code StringSet Q a
} deriving ( Monad, Applicative, Functor, MonadReader (Options, s)
, MonadWriter Code, MonadState StringSet)
instance Fail.MonadFail (CodeGenM s) where
fail = CodeGenM . fail
data Options = Options
{ _extraModules :: [String]
, _derivingTypeclasses :: [Name]
, _replaceModules :: M.Map String String
, _languageExtensions :: [Text]
, _ghcOptsPragmas :: [Text]
, _extraInstances :: Name -> [DecQ]
}
defaultOptions :: Options
defaultOptions = Options
{ _extraModules = [ "Text.Regex"
, "Text.Regex.PCRE.String"
, "Data.Aeson.Types"
, "Data.Ratio"
]
, _derivingTypeclasses = [''Eq, ''Show]
, _replaceModules = M.fromList
[ ("Data.HashMap.Base", "Data.HashMap.Lazy")
, ("Data.Aeson.Types.Class", "Data.Aeson")
, ("Data.Aeson.Types.Internal", "Data.Aeson.Types")
, ("GHC.Integer.Type", "Prelude")
, ("GHC.Types", "Prelude")
, ("GHC.Real", "Prelude")
, ("Data.Text.Internal", "Data.Text")
, ("Data.Map.Base", "Data.Map")
, ("Data.OldList", "Prelude")
, ("Data.Typeable.Internal", "Data.Typeable")
, ("Data.Binary.Class", "Data.Binary")
]
, _languageExtensions = []
, _ghcOptsPragmas = []
, _extraInstances = const []
}
askOpts :: CodeGenM s Options
askOpts = fst <$> ask
askEnv :: CodeGenM s s
askEnv = snd <$> ask
instance Quasi (CodeGenM s) where
qNewName = state . codeGenNewName
qReport b = CodeGenM . MT.lift . qReport b
qRecover (CodeGenM handler) (CodeGenM action) = do
graph <- ask
currState <- get
(a, s, w) <- CodeGenM $ MT.lift $ (recover `on` \m -> runRWST m graph currState) handler action
put s
tell w
return a
qLookupName b = CodeGenM . MT.lift . (if b then lookupTypeName else lookupValueName)
qReify = CodeGenM . MT.lift . reify
qLocation = CodeGenM . MT.lift $ location
qRunIO = CodeGenM . MT.lift . runIO
qAddDependentFile = CodeGenM . MT.lift . addDependentFile
qReifyInstances name = CodeGenM . MT.lift . reifyInstances name
qReifyRoles = CodeGenM . MT.lift . reifyRoles
qReifyAnnotations = CodeGenM . MT.lift . reifyAnnotations
qReifyModule = CodeGenM . MT.lift . reifyModule
qAddTopDecls = CodeGenM . MT.lift . addTopDecls
qAddModFinalizer = CodeGenM . MT.lift . addModFinalizer
qGetQ = CodeGenM $ MT.lift getQ
qPutQ = CodeGenM . MT.lift . putQ
#if MIN_VERSION_template_haskell(2,11,0)
qReifyFixity = CodeGenM . MT.lift . reifyFixity
qReifyConStrictness = CodeGenM . MT.lift . reifyConStrictness
qIsExtEnabled = CodeGenM . MT.lift . isExtEnabled
qExtsEnabled = CodeGenM $ MT.lift extsEnabled
#endif
instance MonadIO (CodeGenM s) where
liftIO = qRunIO
genRecord :: Name
-> [(Name, TypeQ, Maybe Text)]
-> [Name]
-> Q Declaration
genRecord name fields classes = Declaration <$> dataDec
<*> (Just . recordBlock . map fieldLine <$> fields')
where
fields' :: Q [(Name, Type, Maybe Text)]
fields' = mapM (\(fieldName, fieldType, fieldDesc) -> (fieldName,,fieldDesc) <$> fieldType) fields
dataLine, derivingClause :: Text
dataLine = "data " <> pack (nameBase name) <> " = " <> pack (nameBase name)
derivingClause = "deriving (" <> T.intercalate ", " (map (\n -> maybe "" ((<> ".") . pack) (nameModule n) <> pack (nameBase n)) classes) <> ")"
fieldLine :: (Name, Type, Maybe Text) -> Text
fieldLine (fieldName, fieldType, fieldDesc) = mconcat
[ pack (nameBase fieldName)
, " :: "
, pack (pprint fieldType)
, maybe "" ((" " <>) . renderComment . ("^ " <>)) fieldDesc
]
renderComment :: Text -> Text
renderComment = T.intercalate "\n" . map ("-- " <>) . T.lines
recordBlock :: [Text] -> Text
recordBlock [] = dataLine <> " " <> derivingClause
recordBlock (l:ls) = T.unlines $ [dataLine] ++ map indent (["{ " <> l] ++ map (", " <>) ls ++ ["} " <> derivingClause])
indent :: Text -> Text
indent = (" " <>)
#if MIN_VERSION_template_haskell(2,12,0)
constructor = recC name $ map (\(fieldName, fieldType, _) -> (fieldName,Bang NoSourceUnpackedness NoSourceStrictness,) <$> fieldType) fields
deriv = derivClause Nothing $ map conT classes
dataDec = dataD (cxt []) name [] Nothing [constructor] $ [deriv]
#elif MIN_VERSION_template_haskell(2,11,0)
constructor = recC name $ map (\(fieldName, fieldType, _) -> (fieldName,Bang NoSourceUnpackedness NoSourceStrictness,) <$> fieldType) fields
dataDec = dataD (cxt []) name [] Nothing [constructor] $ mapM conT classes
#else
constructor = recC name $ map (\(fieldName, fieldType, _) -> (fieldName,NotStrict,) <$> fieldType) fields
dataDec = dataD (cxt []) name [] [constructor] classes
#endif