module Elm
( ToElm (..)
, Options (..)
, Expr (..)
, Primitive (..)
, Generator (..)
, defaultOptions
, genericToElm
, generateElm
) where
import Data.Char
import Data.List hiding (unlines)
import Data.List.Split
import Data.Text (Text)
import Data.Time
import GHC.Generics
import Prelude hiding (unlines)
import System.Directory
import System.FilePath
data Options = Options
{ recordSelectorModifier :: String -> String
, jsonSelectorModifier :: String -> String
}
defaultOptions :: Options
defaultOptions = Options
{ recordSelectorModifier = id
, jsonSelectorModifier = id
}
data Generator = Type | Decoder | Encoder
deriving (Show, Eq, Ord)
data Primitive = Bool | Char | String | Float | Date | Int | Maybe | List
deriving (Show, Eq)
data Expr = DataType String Expr
| Record String Expr
| Constructor String Expr
| Selector String String Expr
| Field Expr
| Unit
| Sum Expr Expr
| Product Expr Expr
| Primitive Primitive
deriving (Show)
tab :: Int -> String -> String
tab times = (++) (take times $ repeat ' ')
surround :: String -> String -> String -> [String] -> [String]
surround a b c (d:ds) = (a ++ d) : (map ((++) b) ds) ++ [c]
surround a b c _ = a : c : []
unlines :: [String] -> String
unlines = concat . intersperse "\n"
isProduct :: Expr -> Bool
isProduct (Product (Primitive List) (Primitive Char)) = False
isProduct (Product _ _) = True
isProduct _ = False
elmType :: Expr -> String
elmType (Primitive t) = show t
elmType (DataType name _) = name
elmType (Product (Primitive List) (Primitive Char)) = elmType $ Primitive String
elmType (Product (Primitive List) t) =
"List " ++ if isProduct t
then "(" ++ elmType t ++ ")"
else elmType t
elmType (Product (Primitive Maybe) t) =
"Maybe " ++ if isProduct t
then "(" ++ elmType t ++ ")"
else elmType t
elmType (Field f) = elmType f
elmType d = error $ "Unsupported Type: " ++ show d
typeDefinition :: Expr -> String
typeDefinition (DataType name (Record _ expr)) = unlines
[ "type alias " ++ name ++ " ="
, unlines $ map (tab 4) $ surround "{ " ", " "}" $ build expr
]
where build (Product s1 s2) = build s1 ++ build s2
build (Selector selector _ t) = [selector ++ " : " ++ elmType t]
build d = error $ "Unsupported Record type Selector definition: " ++ show d
typeDefinition d = error $ "Unsupported type definition: " ++ show d
elmEncoder :: Expr -> String
elmEncoder (Primitive t) = case t of
Bool ->
"Json.Encode.bool"
String ->
"Json.Encode.string"
Float ->
"Json.Encode.float"
Int ->
"Json.Encode.int"
p -> error $ "No encoder for Primitive known: " ++ show p
elmEncoder (Field f) = elmEncoder f
elmEncoder (DataType name _) = "encode" ++ name
elmEncoder (Product (Primitive List) (Primitive Char)) = elmEncoder $ Primitive String
elmEncoder (Product (Primitive List) t) =
concat $ surround "(" " << " ")"
[ "Json.Encode.list"
, "List.map " ++ elmEncoder t
]
elmEncoder (Product (Primitive Maybe) t) =
concat $ surround "(" " << " ")"
[ "Maybe.withDefault Json.Encode.null"
, "Maybe.map " ++ elmEncoder t
]
elmEncoder d = error $ "No encoder for definition known: " ++ show d
encoder :: Expr -> String
encoder (DataType name (Record _ expr)) = unlines
[ func ++ " : " ++ name ++ " -> Json.Encode.Value"
, func ++ " o ="
, tab 4 "Json.Encode.object"
, unlines $ map (tab 8) $ surround "[ " ", " "]" $ build expr
]
where func = "encode" ++ name
build (Product s1 s2) = build s1 ++ build s2
build (Selector recordSel jsonSel t) =
[ concat $ surround "(" ", " ")"
[ show jsonSel
, (elmEncoder t) ++ " o." ++ recordSel
]
]
build d = error $ "Unsupported Record encoder Selector definition: " ++ show d
encoder d = error $ "Unsupported encoder definition: " ++ show d
elmDecoder :: Expr -> String
elmDecoder (Primitive t) = case t of
String ->
"Json.Decode.string"
Int ->
"Json.Decode.int"
Float ->
"Json.Decode.float"
Date ->
"Json.Decode.Extra.date"
Bool ->
"Json.Decode.bool"
p -> error $ "No decoder for Primitive known: " ++ show p
elmDecoder (Field f) = elmDecoder f
elmDecoder (DataType name _) = "decode" ++ name
elmDecoder (Product (Primitive List) (Primitive Char)) = elmDecoder $ Primitive String
elmDecoder (Product (Primitive List) t) =
"Json.Decode.list " ++ if isProduct t
then "(" ++ elmDecoder t ++ ")"
else elmDecoder t
elmDecoder (Product (Primitive Maybe) t) =
"Json.Decode.maybe " ++ if isProduct t
then "(" ++ elmDecoder t ++ ")"
else elmDecoder t
elmDecoder d = error $ "No decoder for definition known: " ++ show d
decoder :: Expr -> String
decoder (DataType name (Record _ expr)) = unlines
[ func ++ " : Json.Decode.Decoder " ++ name
, func ++ " ="
, tab 4 "Json.Decode.succeed " ++ name
, unlines $ map (tab 8) $ build expr
]
where func = "decode" ++ name
build (Product s1 s2) = build s1 ++ build s2
build (Selector _ selector t) =
[ concat $ surround "|: (" " := " ")"
[ show selector
, elmDecoder t
]
]
build d = error $ "Unsupported Record decoder Selector definition: " ++ show d
decoder d = error $ "Unsupported decoder definition: " ++ show d
imports :: [(Expr, [Generator])] -> [String]
imports inclusions = map format $ ti ++ di ++ ei
where generators = concat $ map snd inclusions
ti = if Type `elem` generators
then [ ("Date", Just "Date")
]
else []
di = if Decoder `elem` generators
then [ ("Json.Decode", Just "(:=)")
, ("Json.Decode.Extra", Just "(|:)")
]
else []
ei = if Encoder `elem` generators
then [ ("Json.Encode", Nothing)
]
else []
format (moduleName, Nothing) = "import " ++ moduleName
format (moduleName, Just exp) = "import " ++ moduleName ++ " exposing (" ++ exp ++ ")"
generate :: Generator -> Expr -> String
generate Type = typeDefinition
generate Decoder = decoder
generate Encoder = encoder
generateElm :: FilePath -> String -> [String] -> [(Expr, [Generator])] -> IO ()
generateElm destination moduleName customImports inclusions = do
createDirectoryIfMissing True directory
writeFile filePath fileBody
putStrLn $ "Generated: " ++ filePath
where namespace = "module " ++ moduleName ++ " exposing (..)"
extraImports = map (\i -> "import " ++ i ++ " exposing (..)") customImports
allImports = unlines $ imports inclusions ++ extraImports
definitions = map (\(e, gs) -> unlines $ pad $ map (flip generate e) gs) inclusions
pad = intersperse "\n"
fileBody = unlines $ pad $ filter (not . null) $
namespace : allImports : definitions
filePath = intercalate "/" (filter (not . null) $ destination : splitOn "." moduleName) ++ ".elm"
directory = takeDirectory filePath
class ToElm a where
toElm :: a -> Expr
default toElm :: (Generic a, GToElm (Rep a)) => a -> Expr
toElm = genericToElm defaultOptions
instance ToElm Bool where
toElm _ = Primitive Bool
instance ToElm Char where
toElm _ = Primitive Char
instance ToElm Text where
toElm _ = Primitive String
instance ToElm Float where
toElm _ = Primitive Float
instance ToElm Double where
toElm _ = Primitive Float
instance ToElm UTCTime where
toElm _ = Primitive Date
instance ToElm Int where
toElm _ = Primitive Int
instance (ToElm a) => ToElm (Maybe a) where
toElm _ = Product (Primitive Maybe) $ toElm (undefined :: a)
instance (ToElm a) => ToElm [a] where
toElm _ = Product (Primitive List) $ toElm (undefined :: a)
class GToElm f where
gToElm :: Options -> f a -> Expr
instance (GToElm f, Datatype d) => GToElm (D1 d f) where
gToElm opts d@(M1 b) =
DataType name expr
where name = datatypeName d
expr = gToElm opts b
instance (GToElm f, Constructor c) => GToElm (C1 c f) where
gToElm opts c@(M1 s) =
if conIsRecord c
then Record name expr
else Constructor name expr
where name = conName c
expr = gToElm opts s
instance (Selector c,GToElm f) => GToElm (S1 c f) where
gToElm opts@(Options {..}) s@(M1 x) = Selector
(dcFirst $ notEmpty "Record" $ recordSelectorModifier name)
(notEmpty "Json" $ jsonSelectorModifier name) expr
where name = selName s
expr = gToElm opts x
notEmpty ident as = if length as > 0
then as
else error $ ident ++ "selector modifier results in empty selector"
dcFirst (a:as) = toLower a : as
dcFirst _ = undefined
instance (ToElm c) => GToElm (K1 R c) where
gToElm _ (K1 x) =
Field $ toElm x
instance GToElm U1 where
gToElm _ _ =
Unit
instance (GToElm f, GToElm g) => GToElm (f :+: g) where
gToElm opts _ =
Sum (gToElm opts (undefined :: f p)) (gToElm opts (undefined :: g p))
instance (GToElm f, GToElm g) => GToElm (f :*: g) where
gToElm opts _ =
Product (gToElm opts (undefined :: f p)) (gToElm opts (undefined :: g p))
genericToElm :: (Generic a, GToElm (Rep a)) => Options -> a -> Expr
genericToElm opts = gToElm opts . from