ElmFormat.hs

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGuaGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGuaGE DeriveGeneric       #-}
{-# LANGuaGE FlexibleContexts    #-}
-- | Formatting type declarations and class instances for inferred types.
module JsonToType.CodeGen.ElmFormat(
  displaySplitTypes,
  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, toList)
import           Data.List                 (foldl1')
import           Data.Char                 (isAlpha, isDigit)
import           Control.Monad.State.Class
import           Control.Monad.State.Strict(State, runState)
import           GHC.Generics              (Generic)

import           JsonToType.Type
import           JsonToType.Extract
import           JsonToType.Split
import           JsonToType.Format
import           JsonToType.Util  ()

--import           Debug.Trace -- DEBUG
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

-- | Wrap a type alias.
wrapAlias :: Text -> Text -> Text
wrapAlias identifier contents = Text.unwords ["type alias ", identifier, "=", contents]

-- | Wrap a data type declaration
wrapDecl ::  Text -> Text -> Text
wrapDecl identifier contents = Text.unlines [header, contents, "  }"]
                                            --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]
  where
    header = Text.concat ["type alias ", identifier, " = ", " { "]

-- | Explanatory type alias for making declarations
-- First element of the triple is original JSON identifier,
-- second element of the triple is the mapped identifier name in Haskell.
-- third element of the triple shows the type in a formatted way
type MappedKey = (Text, Text, Text, Type, Bool)

-- | Make Decoder declaration, given identifier (object name in Haskell) and mapping of its keys
-- from JSON to Haskell identifiers *in the same order* as in *data type declaration*.
makeDecoder ::  Text -> [MappedKey] -> Text
makeDecoder identifier contents =
  Text.unlines [
      Text.concat  [decodeIdentifier, " : Json.Decode.Decoder ", identifier]
    , Text.concat  [decodeIdentifier, " ="]
    , Text.unwords ["    Json.Decode.Pipeline.decode", identifier]
    , Text.unlines (makeParser identifier <$> contents) ]
  where
    decodeIdentifier         = decoderIdent identifier
    makeParser identifier (jsonId, _, _, ty, isOptional) = Text.unwords [
          "  |>"
        , if isOptional
             then "Json.Decode.Pipeline.optional"
             else "Json.Decode.Pipeline.required"
        , Text.concat ["\"", jsonId, "\""]
        , "(" <> getDecoder ty <> ")"] -- quote

getDecoder  TString    = "Json.Decode.string"
getDecoder  TInt       = "Json.Decode.int"
getDecoder  TDouble    = "Json.Decode.float"
getDecoder  TBool      = "Json.Decode.bool"
getDecoder (TArray  t) = "Json.Decode.list (" <> getDecoder t <> ")"
getDecoder (TLabel  l) = decoderIdent l
getDecoder (TObj    o) = error   "getDecoder cannot handle complex object types!"
getDecoder (TUnion  u) = case nonNull of
                           []  -> "Json.Decode.value"
                           [x] -> getDecoder x
                           _   -> foldl1' altDecoder $ map getDecoder nonNull
  where
    nonNull = nonNullComponents u
--error $ "getDecoder cannot yet handle union types:" <> show u

altDecoder a b = "(Json.Decode.oneOf [Json.Decode.map Either.Left ("
              <> a <> "), Json.Decode.map Either.Right ("
              <> b <> ")])"
{-Json.Decode.Pipeline.decode Something
"Json.Decode.Pipeline " <>-}
                     

decoderIdent ident = "decode" <> capitalize (normalizeTypeName ident)
-- Contents example for wrapFromJSON:
-- " <$>
--"                           v .: "hexValue"  <*>
--"                           v .: "colorName\""

encoderIdent ident = "encode" <> capitalize (normalizeTypeName ident)

-- | Make Encoder declaration, given identifier (object name in Haskell) and mapping of its keys
-- from JSON to Haskell identifiers in the same order as in declaration
makeEncoder :: Text -> [MappedKey] -> Text
makeEncoder identifier contents =
    Text.unlines [
        Text.unwords [encoderIdent identifier, ":", identifier, "->", "Json.Encode.Value"]
      , encoderIdent identifier <> " record ="
      , "    Json.Encode.object ["
      , "        " <> (joinWith "\n      , " (makeEncoder <$> contents))
      , "    ]"
      ]
  where
    makeEncoder (jsonId, haskellId, _typeText, ty, _nullable) = Text.concat [
            "(", tShow jsonId, ", (", getEncoder ty, ") record.", normalizeFieldName identifier jsonId, ")"
        ]
    --"answers",  Json.Encode.list <| List.map encodeAnswer <| record.answers
    escapeText = Text.pack . show . Text.unpack

getEncoder :: Type -> Text
getEncoder  TString   = "Json.Encode.string"
getEncoder  TDouble   = "Json.Encode.float"
getEncoder  TInt      = "Json.Encode.int"
getEncoder  TBool     = "Json.Encode.bool"
getEncoder  TNull     = "identity"
getEncoder (TLabel l) = encoderIdent l
getEncoder (TArray e) = "Json.Encode.list << List.map (" <> getEncoder e <> ")"
getEncoder (TObj   o) = error $ "Seeing direct object encoder: "         <> show o
getEncoder (TUnion u) = case nonNull of
                           []  -> "identity"
                           [x] -> getDecoder x
                           _   -> foldl1' altEncoder $ map getEncoder nonNull
  where
    nonNull = nonNullComponents u

altEncoder a b = "Either.unpack (" <> a <> ") (" <> b <> ")"

-- Contents example for wrapToJSON
--"hexValue"  .= hexValue
--                                        ,"colorName" .= colorName]
-- | Join text with other as separator.
joinWith :: Text -> [Text] -> Text
joinWith _      []            = ""
joinWith joiner (aFirst:rest) = aFirst <> Text.concat (map (joiner <>) rest)

-- | Makes a generic identifier name.
genericIdentifier :: DeclM Text
genericIdentifier = do
  i <- stepM
  return $! "Obj" `Text.append` tShow i

-- * Printing a single data type declaration
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, v, isNullable v)
                            let decl = Text.unlines [wrapDecl    identifier $ fieldDecls attrs
                                                    ,""
                                                    ,makeDecoder identifier              attrs
                                                    ,""
                                                    ,makeEncoder identifier              attrs]
                            addDecl decl
                            return identifier
  where
    fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList
    fieldDecl :: (Text, Text, Text, Type, Bool) -> Text
    fieldDecl (_jsonName, haskellName, fType, _type, _nullable) = Text.concat [
                                                                    "    ", haskellName, " : ", fType]

addDecl decl = decls %%= (\ds -> ((), decl:ds))

-- | Add new type alias for Array type
newAlias :: Text -> Type -> DeclM Text
newAlias identifier content = do formatted <- formatType content
                                 addDecl $ Text.unlines [wrapAlias identifier formatted]
                                 return identifier

-- | Convert a JSON key name given by second argument,
-- from within a dictionary keyed with first argument,
-- into a name of Haskell record field (hopefully distinct from other such selectors.)
normalizeFieldName ::  Text -> Text -> Text
normalizeFieldName identifier = escapeKeywords             .
                                uncapitalize               .
                                (normalizeTypeName identifier `Text.append`) .
                                normalizeTypeName

keywords ::  Set Text
keywords = Set.fromList ["type", "alias", "exposing", "module", "class",
                         "where", "let", "do"]

escapeKeywords ::  Text -> Text
escapeKeywords k | k `Set.member` keywords = k `Text.append` "_"
escapeKeywords k                           = k

nonNullComponents = Set.toList . Set.filter (TNull /=)
-- | Format the type within DeclM monad, that records
-- the separate declarations on which this one is dependent.
formatType :: Type -> DeclM Text
formatType  TString                          = return "String"
formatType  TDouble                          = return "Float"
formatType  TInt                             = return "Int"
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
                                                          _ -> foldl1' join <$> mapM formatType nonNull
  where
    nonNull = nonNullComponents u
    wrap                                :: Text -> Text
    wrap   inner  | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"]
                  | otherwise            =                          inner
    join fAlt fOthers = Text.concat ["Either (", fAlt, ") (", fOthers, ")"]
formatType (TArray a)                        = do inner <- formatType a
                                                  return $ Text.concat ["List (", 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 = "Json.Decode.Value" -- default, accepts future extension where we found no data

runDecl ::  DeclM a -> Text
runDecl decl = Text.unlines $ finalState ^. decls
  where
    initialState    = DeclState [] 1
    (_, finalState) = runState decl initialState

-- * Splitting object types by label for unification.
type TypeTree    = Map Text [Type]

type TypeTreeM a = State TypeTree a

addType :: Text -> Type -> TypeTreeM ()
addType label typ = modify $ Map.insertWith (++) label [typ]

formatObjectType ::  Text -> Type -> DeclM Text
formatObjectType identifier (TObj o) = newDecl  identifier d
  where
    d = Map.toList $ unDict o
formatObjectType identifier  other   = newAlias identifier other

-- | Display an environment of types split by name.
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

-- | Normalize type name by:
-- 1. Treating all characters that are not acceptable in Haskell variable name as end of word.
-- 2. Capitalizing each word, but a first (camelCase).
-- 3. Adding underscore if first character is non-alphabetic.
-- 4. Escaping Haskell keywords if the whole identifier is such keyword.
-- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name.
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

-- | Computes all type labels referenced by a given type.
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

-- | Remaps type labels according to a `Map`.
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