{-# 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 = forall s a. State s a -> s -> a
SState.evalState (forall f. ToHType f => Proxy f -> HState HType
toHType Proxy a
p) forall k a. Map k a
DMS.empty
  MData
mdata <-
    case HType
hType of
      HUDef (UDefData MData
m [HType]
_ [HConstructor]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MData
m
      HPrimitive MData
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Direct encoding of primitive type is not supported"
      HMaybe HType
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Direct encoding of maybe type is not supported"
      HList HType
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Direct encoding of list type is not supported"
      HRecursive MData
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected meta data"
      HExternal ExInfo HType
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot generate code for external types"
  GenConfig
s <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ 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 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) = forall s a. State s a -> s -> (a, s)
runState Builder
sc forall k a. Map k a
DMS.empty
      r :: WriterT
  [ExItem] (ReaderT (ElmVersion, GenConfig) Q) (Text -> Text, Text)
r = do
        [Text]
srcs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([GenOption], HType) -> GenM Text
generateOne forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
DMS.elems GenConfig
gc
        Text -> Text
front <- Text -> GenM (Text -> Text)
Elm.elmFront Text
moduleName
        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) <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 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 -> forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> IO ()
T.writeFile [Char]
fp Text
fSrc
           Maybe [Char]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         forall (f :: * -> *) a. Applicative f => a -> f a
pure 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_ =
            forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
DL.foldr (\(Text
m, Text
s) Map Text [Text]
mp -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
DMS.insertWith forall a. [a] -> [a] -> [a]
(++) Text
m [Text
s] Map Text [Text]
mp) forall k a. Map k a
DMS.empty [ExItem]
exs
       in Text -> [Text] -> Text
T.intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$ 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
")"] forall a. a -> [a] -> [a]
:
      [Text]
in_
    toExp :: Text -> Exp
    toExp :: Text -> Exp
toExp Text
t = Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
StringL forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
t
    generateOne :: ([GenOption], HType) -> GenM Text
    generateOne :: ([GenOption], HType) -> GenM Text
generateOne ([GenOption]
gs, HType
ht) = do
      [Text]
srcs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HType -> GenOption -> GenM Text
generateOne_ HType
ht) [GenOption]
gs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"" [Text]
srcs
      where
        generateOne_ :: HType -> GenOption -> GenM Text
        generateOne_ :: HType -> GenOption -> GenM Text
generateOne_ HType
h GenOption
d = GenOption -> HType -> Options -> GenM Text
Elm.generateElm GenOption
d HType
h Options
opt