{-# LANGUAGE OverloadedStrings #-}

-- | Generate Elm type definitions, encoders and decoders from Haskell data types.
module Elminator
  ( module Elminator
  , ElmVersion(..)
  , HType(..)
  , ToHType(..)
  , ExInfo(..)
  , Builder
  , GenOption(..)
  , PolyConfig(..)
  ) where

import Control.Monad.Reader
import Control.Monad.State.Lazy
import qualified Control.Monad.State.Strict as SState
import Control.Monad.Writer
import Data.Aeson (Options)
import Data.List as DL
import qualified Data.Map.Strict as DMS
import Data.Proxy
import Data.Text as T
import Data.Text.IO as T
import qualified Elminator.ELM.Generator as Elm
import Elminator.Generics.Simple
import Elminator.Lib
import Language.Haskell.TH

-- | Include the elm source for the Haskell type specified by the proxy argument.
-- The second argument decides which components will be included and if the
-- generated type will be polymorphic.
include :: (ToHType a) => Proxy a -> GenOption -> Builder
include :: forall a. ToHType a => Proxy a -> GenOption -> Builder
include Proxy a
p GenOption
dc = do
  let hType :: HType
hType = State (Map MData ()) HType -> Map MData () -> HType
forall s a. State s a -> s -> a
SState.evalState (Proxy a -> State (Map MData ()) HType
forall f. ToHType f => Proxy f -> State (Map MData ()) HType
toHType Proxy a
p) Map MData ()
forall k a. Map k a
DMS.empty
  MData
mdata <-
    case HType
hType of
      HUDef (UDefData MData
m [HType]
_ [HConstructor]
_) -> MData -> StateT GenConfig Identity MData
forall a. a -> StateT GenConfig Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MData
m
      HPrimitive MData
_ -> [Char] -> StateT GenConfig Identity MData
forall a. HasCallStack => [Char] -> a
error [Char]
"Direct encoding of primitive type is not supported"
      HMaybe HType
_ -> [Char] -> StateT GenConfig Identity MData
forall a. HasCallStack => [Char] -> a
error [Char]
"Direct encoding of maybe type is not supported"
      HList HType
_ -> [Char] -> StateT GenConfig Identity MData
forall a. HasCallStack => [Char] -> a
error [Char]
"Direct encoding of list type is not supported"
      HRecursive MData
_ -> [Char] -> StateT GenConfig Identity MData
forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected meta data"
      HExternal ExInfo HType
_ -> [Char] -> StateT GenConfig Identity MData
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot generate code for external types"
  GenConfig
s <- StateT GenConfig Identity GenConfig
forall s (m :: * -> *). MonadState s m => m s
get
  GenConfig -> Builder
forall s (m :: * -> *). MonadState s m => s -> m ()
put (GenConfig -> Builder) -> GenConfig -> Builder
forall a b. (a -> b) -> a -> b
$ (([GenOption], HType)
 -> ([GenOption], HType) -> ([GenOption], HType))
-> MData -> ([GenOption], HType) -> GenConfig -> GenConfig
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
DMS.insertWith (\([GenOption]
a, HType
b) ([GenOption]
ea, HType
_) -> ([GenOption]
ea [GenOption] -> [GenOption] -> [GenOption]
forall a. [a] -> [a] -> [a]
++ [GenOption]
a, HType
b)) MData
mdata ([GenOption
dc], HType
hType) GenConfig
s

-- | Return the generated Elm code in a template haskell splice and optionally
-- write to a Elm source file at the same time. The second argument is the Options type
-- from Aeson library. Use `include` calls to build the `Builder` value.
generateFor ::
     ElmVersion -- ^ The target Elm version
  -> Options -- ^ The Aeson.Options
  -> Text -- ^ The name of the target module
  -> Maybe FilePath -- ^ Optional filepath to write the generated source to
  -> Builder -- ^ Configuration made by calls to `include` function.
  -> Q Exp
generateFor :: ElmVersion -> Options -> Text -> Maybe [Char] -> Builder -> Q Exp
generateFor ElmVersion
ev Options
opt Text
moduleName Maybe [Char]
mfp Builder
sc =
  let (()
_, GenConfig
gc) = Builder -> GenConfig -> ((), GenConfig)
forall s a. State s a -> s -> (a, s)
runState Builder
sc GenConfig
forall k a. Map k a
DMS.empty
      r :: WriterT
  [ExItem] (ReaderT (ElmVersion, GenConfig) Q) (Text -> Text, Text)
r = do
        [Text]
srcs <- (([GenOption], HType)
 -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text)
-> [([GenOption], HType)]
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([GenOption], HType)
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text
generateOne ([([GenOption], HType)]
 -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [Text])
-> [([GenOption], HType)]
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [Text]
forall a b. (a -> b) -> a -> b
$ GenConfig -> [([GenOption], HType)]
forall k a. Map k a -> [a]
DMS.elems GenConfig
gc
        Text -> Text
front <- Text -> GenM (Text -> Text)
Elm.elmFront Text
moduleName
        (Text -> Text, Text)
-> WriterT
     [ExItem] (ReaderT (ElmVersion, GenConfig) Q) (Text -> Text, Text)
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text
front, Text -> [Text] -> Text
T.intercalate Text
"" [Text]
srcs)
   in do ((Text -> Text
front, Text
exprtxt), [ExItem]
exinfo) <- ReaderT (ElmVersion, GenConfig) Q ((Text -> Text, Text), [ExItem])
-> (ElmVersion, GenConfig) -> Q ((Text -> Text, Text), [ExItem])
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (WriterT
  [ExItem] (ReaderT (ElmVersion, GenConfig) Q) (Text -> Text, Text)
-> ReaderT
     (ElmVersion, GenConfig) Q ((Text -> Text, Text), [ExItem])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT
  [ExItem] (ReaderT (ElmVersion, GenConfig) Q) (Text -> Text, Text)
r) (ElmVersion
ev, GenConfig
gc)
         let fSrc :: Text
fSrc = [Text] -> Text
T.concat [Text -> Text
front (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [ExItem] -> Text
toImport [ExItem]
exinfo, Text
"\n\n", Text
exprtxt]
         case Maybe [Char]
mfp of
           Just [Char]
fp -> IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> IO ()
T.writeFile [Char]
fp Text
fSrc
           Maybe [Char]
Nothing -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> Exp
toExp Text
fSrc
  where
    toImport :: [ExItem] -> Text
    toImport :: [ExItem] -> Text
toImport [ExItem]
exs =
      let map_ :: Map Text [Text]
map_ =
            (ExItem -> Map Text [Text] -> Map Text [Text])
-> Map Text [Text] -> [ExItem] -> Map Text [Text]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
DL.foldr (\(Text
m, Text
s) Map Text [Text]
mp -> ([Text] -> [Text] -> [Text])
-> Text -> [Text] -> Map Text [Text] -> Map Text [Text]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
DMS.insertWith [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
(++) Text
m [Text
s] Map Text [Text]
mp) Map Text [Text]
forall k a. Map k a
DMS.empty [ExItem]
exs
       in Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> [Text] -> [Text] -> [Text])
-> [Text] -> Map Text [Text] -> [Text]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
DMS.foldrWithKey' Text -> [Text] -> [Text] -> [Text]
foldFn [] Map Text [Text]
map_
    foldFn :: Text -> [Text] -> [Text] -> [Text]
    foldFn :: Text -> [Text] -> [Text] -> [Text]
foldFn Text
mod_ [Text]
smbs [Text]
in_ =
      [Text] -> Text
T.concat [Text
"import ", Text
mod_, Text
" exposing (", Text -> [Text] -> Text
T.intercalate Text
", " [Text]
smbs, Text
")"] Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
      [Text]
in_
    toExp :: Text -> Exp
    toExp :: Text -> Exp
toExp Text
t = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
StringL ([Char] -> Lit) -> [Char] -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
t
    generateOne :: ([GenOption], HType) -> GenM Text
    generateOne :: ([GenOption], HType)
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text
generateOne ([GenOption]
gs, HType
ht) = do
      [Text]
srcs <- (GenOption
 -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text)
-> [GenOption]
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HType
-> GenOption
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text
generateOne_ HType
ht) [GenOption]
gs
      Text -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text)
-> Text
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"" [Text]
srcs
      where
        generateOne_ :: HType -> GenOption -> GenM Text
        generateOne_ :: HType
-> GenOption
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text
generateOne_ HType
h GenOption
d = GenOption
-> HType
-> Options
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Text
Elm.generateElm GenOption
d HType
h Options
opt