module Data.Aeson.AutoType.Format(
displaySplitTypes, splitTypeByLabel, unificationCandidates,
unifyCandidates,
normalizeTypeName
) where
import Control.Arrow ((&&&))
import Control.Applicative ((<$>), (<*>))
import Control.Lens.TH
import Control.Lens
import Control.Monad (forM)
import Control.Exception(assert)
import qualified Data.HashMap.Strict as Map
import Data.Monoid
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Text (Text)
import Data.Set (Set )
import Data.List (foldl1')
import Data.Char (isAlpha, isDigit)
import Control.Monad.State.Class
import Control.Monad.State.Strict(State, runState)
import qualified Data.Graph as Graph
import GHC.Generics (Generic)
import Data.Aeson.AutoType.Type
import Data.Aeson.AutoType.Extract
import Data.Aeson.AutoType.Util ()
trace _ x = x
fst3 :: (t, t1, t2) -> t
fst3 (a, _b, _c) = a
data DeclState = DeclState { _decls :: [Text]
, _counter :: Int
}
deriving (Eq, Show, Ord, Generic)
makeLenses ''DeclState
type DeclM = State DeclState
type Map k v = Map.HashMap k v
stepM :: DeclM Int
stepM = counter %%= (\i -> (i, i+1))
tShow :: (Show a) => a -> Text
tShow = Text.pack . show
wrapAlias :: Text -> Text -> Text
wrapAlias identifier contents = Text.unwords ["type", identifier, "=", contents]
wrapDecl :: Text -> Text -> Text
wrapDecl identifier contents = Text.unlines [header, contents, " } deriving (Show,Eq,Generic)"]
where
header = Text.concat ["data ", identifier, " = ", identifier, " { "]
type MappedKey = (Text, Text, Text, Bool)
makeFromJSON :: Text -> [MappedKey] -> Text
makeFromJSON identifier contents =
Text.unlines [
Text.unwords ["instance FromJSON", identifier, "where"]
, Text.unwords [" parseJSON (Object v) =", makeParser identifier contents]
, " parseJSON _ = mzero" ]
where
makeParser identifier [] = Text.unwords ["return ", identifier]
makeParser identifier _ = Text.unwords [identifier, "<$>", inner]
inner = " <*> " `Text.intercalate`
map takeValue contents
takeValue (jsonId, _, ty, True ) = Text.concat ["v .:?? \"", jsonId, "\""]
takeValue (jsonId, _, _ , False) = Text.concat ["v .: \"", jsonId, "\""]
makeToJSON :: Text -> [MappedKey] -> Text
makeToJSON identifier contents =
Text.unlines [
Text.concat ["instance ToJSON ", identifier, " where"]
, Text.concat [" toJSON (", identifier, " {", wildcard, "}) = object [", inner ", ", "]"]
#if MIN_VERSION_aeson(0,11,0)
, maybeToEncoding
#endif
]
where
maybeToEncoding | null contents = ""
| otherwise =
Text.concat [" toEncoding (", identifier, " {", wildcard, "}) = pairs (", inner "<>", ")"]
wildcard | null contents = ""
| otherwise = ".."
inner separator = separator `Text.intercalate`
map putValue contents
putValue (jsonId, haskellId, _typeText, _nullable) = Text.unwords [escapeText jsonId, ".=", haskellId]
escapeText = Text.pack . show . Text.unpack
genericIdentifier :: DeclM Text
genericIdentifier = do
i <- stepM
return $! "Obj" `Text.append` tShow i
newDecl :: Text -> [(Text, Type)] -> DeclM Text
newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do
formatted <- formatType v
return (k, normalizeFieldName identifier k, formatted, isNullable v)
let decl = Text.unlines [wrapDecl identifier $ fieldDecls attrs
,""
,makeFromJSON identifier attrs
,""
,makeToJSON identifier attrs]
addDecl decl
return identifier
where
fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList
fieldDecl :: (Text, Text, Text, Bool) -> Text
fieldDecl (_jsonName, haskellName, fType, _nullable) = Text.concat [
" ", haskellName, " :: ", fType]
addDecl decl = decls %%= (\ds -> ((), decl:ds))
newAlias :: Text -> Type -> DeclM Text
newAlias identifier content = do formatted <- formatType content
addDecl $ Text.unlines [wrapAlias identifier formatted]
return identifier
normalizeFieldName :: Text -> Text -> Text
normalizeFieldName identifier = escapeKeywords .
uncapitalize .
(normalizeTypeName identifier `Text.append`) .
normalizeTypeName
keywords :: Set Text
keywords = Set.fromList ["type", "data", "module", "class", "where", "let", "do"]
escapeKeywords :: Text -> Text
escapeKeywords k | k `Set.member` keywords = k `Text.append` "_"
escapeKeywords k = k
formatType :: Type -> DeclM Text
formatType TString = return "Text"
formatType TNum = return "Double"
formatType TBool = return "Bool"
formatType (TLabel l) = return $ normalizeTypeName l
formatType (TUnion u) = wrap <$> case length nonNull of
0 -> return emptyTypeRepr
1 -> formatType $ head nonNull
_ -> Text.intercalate ":|:" <$> mapM formatType nonNull
where
nonNull = Set.toList $ Set.filter (TNull /=) u
wrap :: Text -> Text
wrap inner | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"]
| otherwise = inner
formatType (TArray a) = do inner <- formatType a
return $ Text.concat ["[", inner, "]"]
formatType (TObj o) = do ident <- genericIdentifier
newDecl ident d
where
d = Map.toList $ unDict o
formatType e | e `Set.member` emptySetLikes = return emptyTypeRepr
formatType t = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t
emptyTypeRepr :: Text
emptyTypeRepr = "(Maybe Value)"
runDecl :: DeclM a -> Text
runDecl decl = Text.unlines $ finalState ^. decls
where
initialState = DeclState [] 1
(_, finalState) = runState decl initialState
type TypeTree = Map Text [Type]
type TypeTreeM a = State TypeTree a
addType :: Text -> Type -> TypeTreeM ()
addType label typ = modify $ Map.insertWith (++) label [typ]
splitTypeByLabel' :: Text -> Type -> TypeTreeM Type
splitTypeByLabel' _ TString = return TString
splitTypeByLabel' _ TNum = return TNum
splitTypeByLabel' _ TBool = return TBool
splitTypeByLabel' _ TNull = return TNull
splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r
splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u
return $! TUnion $! Set.fromList m
splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a
return $! TArray m
splitTypeByLabel' l (TObj o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do
component <- splitTypeByLabel' k v
return (k, component)
addType l (TObj $ Dict $ Map.fromList kvs)
return $! TLabel l
splitTypeByLabel :: Text -> Type -> Map Text Type
splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState
where
finalize (TLabel l) = assert (l == topLabel) $ return ()
finalize topLevel = addType topLabel topLevel
initialState = Map.empty
(_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState
formatObjectType :: Text -> Type -> DeclM Text
formatObjectType identifier (TObj o) = newDecl identifier d
where
d = Map.toList $ unDict o
formatObjectType identifier other = newAlias identifier other
displaySplitTypes :: Map Text Type -> Text
displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations
where
declarations =
forM (toposort dict) $ \(name, typ) ->
formatObjectType (normalizeTypeName name) typ
normalizeTypeName :: Text -> Text
normalizeTypeName s = ifEmpty "JsonEmptyKey" .
escapeKeywords .
escapeFirstNonAlpha .
Text.concat .
map capitalize .
filter (not . Text.null) .
Text.split (not . acceptableInVariable) $ s
where
ifEmpty x "" = x
ifEmpty _ nonEmpty = nonEmpty
acceptableInVariable c = isAlpha c || isDigit c
escapeFirstNonAlpha cs | Text.null cs = cs
escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha c = cs
escapeFirstNonAlpha cs = "_" `Text.append` cs
capitalize :: Text -> Text
capitalize word = Text.toUpper first `Text.append` rest
where
(first, rest) = Text.splitAt 1 word
uncapitalize :: Text -> Text
uncapitalize word = Text.toLower first `Text.append` rest
where
(first, rest) = Text.splitAt 1 word
toposort :: Map Text Type -> [(Text, Type)]
toposort splitted = map ((id &&& (splitted Map.!)) . fst3 . graphKey) $ Graph.topSort graph
where
(graph, graphKey) = Graph.graphFromEdges' $ map makeEntry $ Map.toList splitted
makeEntry (k, v) = (k, k, allLabels v)
allLabels :: Type -> [Text]
allLabels = flip go []
where
go (TLabel l) ls = l:ls
go (TArray t) ls = go t ls
go (TUnion u) ls = Set.foldr go ls u
go (TObj o) ls = Map.foldr go ls $ unDict o
go _other ls = ls
unificationCandidates :: Map.HashMap t Type -> [[t]]
unificationCandidates = Map.elems .
Map.filter candidates .
Map.fromListWith (++) .
concatMap entry .
Map.toList
where
candidates [ ] = False
candidates [_] = False
candidates _ = True
entry (k, TObj o) = [(Set.fromList $ Map.keys $ unDict o, [k])]
entry _ = []
unifyCandidates :: [[Text]] -> Map Text Type -> Map Text Type
unifyCandidates candidates splitted = Map.map (remapLabels labelMapping) $ replacements splitted
where
unifiedType :: [Text] -> Type
unifiedType cset = foldr1 unifyTypes $
map (splitted Map.!) cset
replace :: [Text] -> Map Text Type -> Map Text Type
replace cset@(c:_) s = Map.insert c (unifiedType cset) (foldr Map.delete s cset)
replace [] _ = error "Empty candidate set in replace"
replacements :: Map Text Type -> Map Text Type
replacements s = foldr replace s candidates
labelMapping :: Map Text Text
labelMapping = Map.fromList $ concatMap mapEntry candidates
mapEntry cset@(c:_) = [(x, c) | x <- cset]
mapEntry [] = error "Empty candidate set in mapEntry"
remapLabels :: Map Text Text -> Type -> Type
remapLabels ls (TObj o) = TObj $ Dict $ Map.map (remapLabels ls) $ unDict o
remapLabels ls (TArray t) = TArray $ remapLabels ls t
remapLabels ls (TUnion u) = TUnion $ Set.map (remapLabels ls) u
remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls
remapLabels _ other = other