module Data.Aeson.Schema.CodeGenM
( Declaration (..)
, Code
, CodeGenM (..)
, renderDeclaration
, codeGenNewName
) where
import Control.Applicative (Applicative (..))
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 Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH.Ppr (pprint)
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 s Code StringSet Q a
} deriving (Monad, Applicative, Functor, MonadReader s, MonadWriter Code, MonadState StringSet)
instance Quasi (CodeGenM s) where
qNewName = state . codeGenNewName
qReport b = CodeGenM . MT.lift . report 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
qReifyInstances name = CodeGenM . MT.lift . reifyInstances name
qLocation = CodeGenM . MT.lift $ location
qRunIO = CodeGenM . MT.lift . runIO
qAddDependentFile = CodeGenM . MT.lift . addDependentFile
instance MonadIO (CodeGenM s) where
liftIO = qRunIO