module Data.Aeson.Flow
(
FlowTyped (..)
, FlowType
, Fix (..)
, FlowTypeF (..)
, FlowModuleOptions (..)
, defaultFlowModuleOptions
, Export (..)
, generateFlowModule
, writeFlowModule
, exportFlowTypeAs
, showFlowType
, dependencies
, defaultFlowType
, defaultFlowTypeName
, FlowName (..)
, PrimType (..)
, GFlowTyped
, FlowTypeI
, Info (..)
, Var (..)
) where
import Control.Monad
import qualified Data.Aeson as A
import Data.Aeson.Types (Options (..), SumEncoding (..))
import Data.Fixed (Fixed)
import Data.Foldable
import Data.Functor.Classes
import Data.Functor.Compose
import Data.Functor.Foldable hiding (fold)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import qualified Data.HashSet as HashSet
import Data.Int
import qualified Data.IntSet as IntSet
import Data.Proxy
import Data.Reflection
import Data.Scientific (Scientific)
import qualified Data.Set as Set
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Text.Lazy as TL
import Data.Time (UTCTime)
import qualified Data.Tree as Tree
import Data.Typeable
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import qualified Data.Void as Void
import Data.Word
import GHC.Generics
import GHC.TypeLits
import qualified Text.PrettyPrint.Leijen as PP
inj :: Proxy s -> a -> Inj s a
inj _ = Inj
newtype Inj s a = Inj a
instance Reifies s (Int -> a -> ShowS) => Show (Inj s a) where
showsPrec i (Inj a) = reflect (Proxy :: Proxy s) i a
data Showy f a = forall s. Reifies s (Int -> a -> ShowS) => Showy (f (Inj s a))
instance Show1 (Showy FlowTypeF) where
liftShowsPrec _ _ i (Showy a) = showsPrec i a
data PrimType
= Boolean
| Number
| String
| Void
| Mixed
| Any
deriving (Show, Read, Eq, Ord)
newtype Var = Var { varName :: Text }
deriving (Show, Read, Eq, Ord)
data FlowName where
FlowName :: (Typeable a, FlowTyped a) => Proxy a -> Text -> FlowName
instance Show FlowName where
show (FlowName _ t) = show t
instance Eq FlowName where
FlowName pa _ == FlowName pb _ = typeOf pa == typeOf pb
instance Ord FlowName where
FlowName pa _ `compare` FlowName pb _ = compare (typeOf pa) (typeOf pb)
data FlowTypeF a
= Object !(HashMap Text a)
| ExactObject !(HashMap Text a)
| ObjectMap !Text a
| Array a
| Tuple !(Vector a)
| Fun !(Vector (Text, a)) a
| Alt a a
| Prim !PrimType
| Nullable a
| Omitable a
| Literal !A.Value
| Tag !Text
| Name !FlowName
| Poly !Var !(Vector a)
| PolyVar !Var
deriving (Show, Eq, Functor, Traversable, Foldable)
instance Show1 FlowTypeF where
liftShowsPrec sp sl i a =
liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a)))
data Info a = Constr !Text FlowTypeI a | NoInfo a
deriving (Show, Functor, Traversable, Foldable)
instance Show1 (Showy Info) where
liftShowsPrec _ _ i (Showy a) = showsPrec i a
instance Show1 Info where
liftShowsPrec sp sl i a =
liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a)))
type FlowTypeI = Fix (Info `Compose` FlowTypeF)
type FlowType = Fix FlowTypeF
text :: Text -> PP.Doc
text = PP.text . T.unpack
ppAlts :: [FlowType] -> FlowType -> PP.Doc
ppAlts alts (Fix f) = case f of
Alt a b -> ppAlts (a:alts) b
x -> PP.align (sep (map pp (reverse (Fix x:alts))))
where
sep [x] = x
sep (x:xs) = x PP.<+> PP.string "|" PP.<$> sep xs
sep _ = PP.empty
braceList :: [PP.Doc] -> PP.Doc
braceList =
(\s -> PP.lbrace PP.</> s PP.</> PP.rbrace)
. PP.align
. PP.sep
. PP.punctuate PP.comma
braceBarList :: [PP.Doc] -> PP.Doc
braceBarList =
(\s -> PP.text "{|" PP.</> s PP.</> PP.text "|}")
. PP.align
. PP.sep
. PP.punctuate PP.comma
ppJson :: A.Value -> PP.Doc
ppJson v = case v of
A.Array a -> PP.list (map ppJson (V.toList a))
A.String t -> PP.squotes (text t)
A.Number n -> PP.string (show n)
A.Bool t -> if t then PP.string "true" else PP.string "false"
A.Null -> PP.string "null"
A.Object obj ->
braceBarList
(map
(\(name, fty) ->
PP.space PP.<> text name PP.<+> PP.colon PP.<+> ppJson fty PP.<> PP.space)
(H.toList obj))
mayWrap :: FlowType -> PP.Doc -> PP.Doc
mayWrap (Fix f) x = case f of
Nullable _ -> PP.parens x
Omitable _ -> PP.parens x
Alt _ _ -> PP.parens x
Array _ -> PP.parens x
_ -> x
ppObject :: HashMap Text FlowType -> [PP.Doc]
ppObject = map
(\(name, fty') ->
case fty' of
Fix (Omitable fty) -> text name PP.<> PP.text "?" PP.<> PP.colon PP.<+> pp fty
fty -> text name PP.<> PP.colon PP.<+> pp fty)
. H.toList
pp :: FlowType -> PP.Doc
pp (Fix ft) = case ft of
ObjectMap keyName a -> braceList
[ PP.brackets (text keyName PP.<> PP.text ": string") PP.<>
PP.colon PP.<+>
pp a
]
Object hm -> braceList (ppObject hm)
ExactObject hm -> braceBarList (ppObject hm)
Array a -> mayWrap a (pp a) PP.<> PP.string "[]"
Tuple t -> PP.list (map pp (V.toList t))
Alt a b -> ppAlts [a] b
Prim pt -> case pt of
Boolean -> PP.text "boolean"
Number -> PP.text "number"
String -> PP.text "string"
Void -> PP.text "void"
Any -> PP.text "any"
Mixed -> PP.text "mixed"
Nullable a -> PP.char '?' PP.<> mayWrap a (pp a)
Omitable a -> PP.char '?' PP.<> mayWrap a (pp a)
Literal a -> ppJson a
Tag t -> PP.squotes (text t)
Name (FlowName _ t) -> text t
_ -> PP.string (show ft)
showFlowType :: FlowType -> Text
showFlowType = T.pack . show . pp
exportFlowTypeAs :: Text -> FlowType -> Text
exportFlowTypeAs name ft =
T.pack . render $
PP.string "export type " PP.<>
PP.string (T.unpack name) PP.<+> PP.string "=" PP.<$>
PP.indent 2 (pp ft) PP.<> PP.string ";"
where
render = ($[]) . PP.displayS . PP.renderPretty 1.0 80
dependencies :: FlowTyped a => Proxy a -> Set.Set FlowName
dependencies p0 = subDeps (immediateDeps (flowType p0) Set.empty)
where
this :: Set.Set FlowName
this = foldMap Set.singleton (FlowName p0 <$> flowTypeName p0)
subDeps :: Set.Set FlowName -> Set.Set FlowName
subDeps =
foldr
(\fn@(FlowName p _) acc ->
if Set.member fn acc
then acc
else dependencies p `Set.union` acc)
this
immediateDeps :: FlowType -> Set.Set FlowName -> Set.Set FlowName
immediateDeps (Fix (Name n)) acc = Set.insert n acc
immediateDeps (Fix p) acc = foldr' immediateDeps acc p
data FlowModuleOptions = FlowModuleOptions
{
flowPragmas :: [Text]
, flowHeader :: [Text]
} deriving (Eq, Show)
defaultFlowModuleOptions :: FlowModuleOptions
defaultFlowModuleOptions = FlowModuleOptions
{ flowPragmas = ["// @flow"]
, flowHeader = ["This module has been generated by aeson-flowtyped."]
}
data Export where
Export :: FlowTyped a => Proxy a -> Export
generateFlowModule :: FlowModuleOptions -> [Export] -> Text
generateFlowModule opts =
T.unlines
. (\m ->
(flowPragmas opts ++ map ("// " `T.append`) (flowHeader opts)) ++
(T.empty : m))
. foldr addExport []
. Set.unions
. map (\(Export a) -> dependencies a)
where
addExport (FlowName p name) acc =
exportFlowTypeAs name (flowType p):acc
writeFlowModule :: FlowModuleOptions -> FilePath -> [Export] -> IO ()
writeFlowModule opts path =
TIO.writeFile path . generateFlowModule opts
defaultFlowType :: (Generic a, GFlowTyped (Rep a)) => Options -> Proxy a -> FlowType
defaultFlowType opt p = gflowType opt (fmap from p)
defaultFlowTypeName
:: (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name)
=> Proxy a
-> Maybe Text
defaultFlowTypeName p = Just (T.pack (symbolVal (pGetName (fmap from p))))
where
pGetName :: Proxy (D1 ('MetaData name mod pkg t) c x) -> Proxy name
pGetName _ = Proxy
flowTypePreferName :: (Typeable a, FlowTyped a) => Proxy a -> FlowType
flowTypePreferName p = case flowTypeName p of
Just n -> Fix (Name (FlowName p n))
Nothing -> flowType p
class Typeable a => FlowTyped a where
flowType :: Proxy a -> FlowType
flowTypeName :: Proxy a -> Maybe Text
flowOptions :: Proxy a -> Options
flowOptions _ = A.defaultOptions
isPrim :: Proxy a -> Bool
isPrim _ = False
default flowType :: (Generic a, GFlowTyped (Rep a)) => Proxy a -> FlowType
flowType p = defaultFlowType (flowOptions p) p
default flowTypeName
:: (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name)
=> Proxy a
-> Maybe Text
flowTypeName = defaultFlowTypeName
class GFlowTyped g where
gflowType :: Options -> Proxy (g x) -> FlowType
class GFlowVal g where
gflowVal :: Options -> Proxy (g x) -> FlowTypeI
instance (KnownSymbol name, GFlowVal c) =>
GFlowTyped (D1 ('MetaData name mod pkg t) c) where
gflowType opt _ = runFlowI (checkNullary (gflowVal opt (Proxy :: Proxy (c x))))
where
checkNullary :: FlowTypeI -> FlowTypeI
checkNullary i
| allNullaryToStringTag opt, Just r <- go [] i, not (null r) =
foldr1
(\a b -> FC (NoInfo (Alt a b)))
(map (FC . NoInfo . Tag) r)
| otherwise = i
where
isNullary :: FlowTypeI -> Bool
isNullary (FC (Info (Prim Void))) = True
isNullary _ = False
go :: [Text] -> FlowTypeI -> Maybe [Text]
go alts (FC (Constr name h _)) = (name:alts) <$ guard (isNullary h)
go alts (FC (NoInfo (Alt a b))) =
case (a, b) of
(FC (Constr nameA ha _), FC (Constr nameB hb _)) ->
(nameA:nameB:alts) <$
guard (isNullary ha && isNullary hb)
(FC (Constr nameA ha _), b') -> do
guard (isNullary ha)
(nameA:) <$> go alts b'
(a', FC (Constr nameB hb _)) -> do
guard (isNullary hb)
(nameB:) <$> go alts a'
_ -> do
as <- go alts a
bs <- go [] b
return (as ++ bs)
go _ _ =
Nothing
runFlowI :: FlowTypeI -> FlowType
runFlowI = cata $ \(Compose i) -> case i of
Constr _name _t a -> Fix a
NoInfo a -> Fix a
gconstrName :: forall conName fx isRecord r x.
KnownSymbol conName
=> Options
-> Proxy (C1 ('MetaCons conName fx isRecord) r x)
-> Text
gconstrName opt _ =
T.pack (constructorTagModifier opt (symbolVal (Proxy :: Proxy conName)))
gfieldName :: forall name su ss ds r x.
KnownSymbol name
=> Options
-> Proxy (S1 ('MetaSel ('Just name) su ss ds) r x)
-> Text
gfieldName opt _ =
T.pack (fieldLabelModifier opt (symbolVal (Proxy :: Proxy name)))
noInfo :: f (Fix (Compose Info f)) -> Fix (Compose Info f)
noInfo = Fix . Compose . NoInfo
infoConstr :: Text -> FlowTypeI -> f (Fix (Compose Info f)) -> Fix (Compose Info f)
infoConstr tag nxt = Fix . Compose . Constr tag nxt
discardInfo :: Info a -> a
discardInfo (NoInfo a) = a
discardInfo (Constr _ _ a) = a
pattern Info :: a -> Info a
pattern Info a <- (discardInfo -> a)
where Info = NoInfo
pattern FC :: f (g (Fix (Compose f g))) -> Fix (Compose f g)
pattern FC a = Fix (Compose a)
instance (KnownSymbol conName, GFlowRecord r) =>
GFlowVal (C1 ('MetaCons conName fx 'True) r) where
gflowVal opt p = noInfo $ case sumEncoding opt of
TaggedObject tfn _ -> ExactObject $!
H.insert (T.pack tfn) (noInfo (Tag tagName))
next
UntaggedValue -> Object next
ObjectWithSingleField -> ExactObject (H.fromList [(tagName, noInfo (Object next))])
TwoElemArray -> Tuple (V.fromList [noInfo (Tag tagName), noInfo (Object next)])
where
omitNothings =
if omitNothingFields opt
then H.map $ \(Fix t) -> Fix $ case t of
Nullable a -> Omitable a
_ -> t
else id
next =
H.map
(cata noInfo)
(omitNothings (gflowRecordFields opt (fmap unM1 p)))
tagName = gconstrName opt p
instance (KnownSymbol conName, GFlowVal r) =>
GFlowVal (C1 ('MetaCons conName fx 'False) r) where
gflowVal opt p = infoConstr tagName next $ case sumEncoding opt of
TaggedObject tfn cfn -> ExactObject (H.fromList
[ (T.pack tfn, noInfo (Tag tagName))
, (T.pack cfn, next)
])
UntaggedValue -> discardInfo n
ObjectWithSingleField -> ExactObject (H.fromList [(tagName, next)])
TwoElemArray -> Tuple (V.fromList [noInfo (Tag tagName), next])
where
next@(Fix (Compose n)) = gflowVal opt (fmap unM1 p)
tagName = gconstrName opt p
instance GFlowVal f => GFlowVal (M1 i ('MetaSel mj du ds dl) f) where
gflowVal opt p = gflowVal opt (fmap unM1 p)
instance FlowTyped r => GFlowVal (Rec0 r) where
gflowVal _opt p = case flowTypePreferName (fmap unK1 p) of
ty
| not (isPrim p'), Just name <- flowTypeName p' -> noInfo (Name (FlowName p' name))
| otherwise -> cata noInfo ty
where
p' = fmap unK1 p
instance (GFlowVal a, GFlowVal b) => GFlowVal (a :+: b) where
gflowVal opt _ = noInfo
(Alt
(gflowVal opt (Proxy :: Proxy (a x)))
(gflowVal opt (Proxy :: Proxy (b x))))
instance (GFlowVal a, GFlowVal b) => GFlowVal (a :*: b) where
gflowVal opt _ = noInfo $
case (fA, fB) of
(Tuple tfA, Tuple tfB) -> Tuple (tfA V.++ tfB)
(Tuple tfA, _) -> Tuple (V.snoc tfA b)
(_ , Tuple tfB) -> Tuple (V.cons a tfB)
_ -> Tuple (V.fromList [a, b])
where
a@(Fix (Compose (Info fA))) = gflowVal opt (Proxy :: Proxy (a x))
b@(Fix (Compose (Info fB))) = gflowVal opt (Proxy :: Proxy (b x))
instance GFlowVal U1 where
gflowVal _ _ = noInfo (Prim Void)
class GFlowRecord a where
gflowRecordFields :: Options -> Proxy (a x) -> HashMap Text FlowType
instance (KnownSymbol fieldName, GFlowVal ty) =>
GFlowRecord (S1 ('MetaSel ('Just fieldName) su ss ds) ty) where
gflowRecordFields opt p =
H.singleton
(gfieldName opt p)
(cata
(Fix . discardInfo . getCompose)
(gflowVal opt (Proxy :: Proxy (ty x))))
instance (GFlowRecord f, GFlowRecord g) =>
GFlowRecord (f :*: g) where
gflowRecordFields opt _ =
let
fx = gflowRecordFields opt (Proxy :: Proxy (f x))
gx = gflowRecordFields opt (Proxy :: Proxy (g x))
in
H.union fx gx
instance FlowTyped a => FlowTyped [a] where
flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))
isPrim _ = True
flowTypeName _ = Nothing
instance FlowTyped a => FlowTyped (Vector a) where
flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))
isPrim _ = True
flowTypeName _ = Nothing
instance FlowTyped a => FlowTyped (VU.Vector a) where
flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))
isPrim _ = True
flowTypeName _ = Nothing
instance FlowTyped a => FlowTyped (VS.Vector a) where
flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))
isPrim _ = True
flowTypeName _ = Nothing
instance (FlowTyped a, FlowTyped b) => FlowTyped (a, b) where
flowTypeName _ = Nothing
flowType _ =
Fix (Tuple (V.fromList [aFt, bFt]))
where
aFt = flowTypePreferName (Proxy :: Proxy a)
bFt = flowTypePreferName (Proxy :: Proxy b)
instance FlowTyped a => FlowTyped (Maybe a) where
flowType _ = Fix (Nullable (flowTypePreferName (Proxy :: Proxy a)))
isPrim _ = True
flowTypeName _ = Nothing
instance (FlowTyped a, FlowTyped b) => FlowTyped (Either a b) where
flowTypeName _ = Nothing
flowType _ = Fix
(Alt
(Fix (ExactObject (H.fromList [("Left", aFt)])))
(Fix (ExactObject (H.fromList [("Right", bFt)]))))
where
aFt = flowTypePreferName (Proxy :: Proxy a)
bFt = flowTypePreferName (Proxy :: Proxy b)
instance ( FlowTyped a
, FlowTyped b
, FlowTyped c
) => FlowTyped (a, b, c) where
flowTypeName _ = Nothing
flowType _ = Fix (Tuple (V.fromList [aFt, bFt, cFt]))
where
aFt = flowTypePreferName (Proxy :: Proxy a)
bFt = flowTypePreferName (Proxy :: Proxy b)
cFt = flowTypePreferName (Proxy :: Proxy c)
instance FlowTyped Text where
isPrim _ = True
flowType _ = Fix (Prim String)
flowTypeName _ = Nothing
instance FlowTyped TL.Text where
isPrim _ = True
flowType _ = Fix (Prim String)
flowTypeName _ = Nothing
instance FlowTyped String where
isPrim _ = True
flowType _ = Fix (Prim String)
flowTypeName _ = Nothing
instance FlowTyped Void.Void where
isPrim _ = True
flowType _ = Fix (Prim Void)
flowTypeName _ = Nothing
instance FlowTyped Char where
isPrim _ = True
flowType _ = Fix (Prim String)
flowTypeName _ = Nothing
instance FlowTyped Bool where
isPrim _ = True
flowType _ = Fix (Prim Boolean)
flowTypeName _ = Nothing
instance FlowTyped A.Value where
isPrim _ = True
flowType _ = Fix (Prim Mixed)
flowTypeName _ = Nothing
instance FlowTyped UTCTime where
isPrim _ = False
flowType _ = Fix (Prim String)
flowTypeName _ = Nothing
instance Typeable a => FlowTyped (Fixed a) where
isPrim _ = False
flowType _ = Fix (Prim Number)
flowTypeName _ = Nothing
instance FlowTyped a => FlowTyped (HashMap Text a) where
isPrim _ = True
flowType _ = Fix (ObjectMap "key" (flowTypePreferName (Proxy :: Proxy a)))
flowTypeName _ = Nothing
instance FlowTyped a => FlowTyped (Set.Set a) where
isPrim _ = False
flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))
flowTypeName _ = Nothing
instance FlowTyped IntSet.IntSet where
isPrim _ = False
flowType _ = Fix (Array (Fix (Prim Number)))
flowTypeName _ = Nothing
instance FlowTyped a => FlowTyped (HashSet.HashSet a) where
isPrim _ = False
flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))
flowTypeName _ = Nothing
instance FlowTyped a => FlowTyped (Tree.Tree a) where
isPrim _ = False
flowType _ = Fix (Tuple
(V.fromList
[ flowType (Proxy :: Proxy a)
, Fix (Array (flowType (Proxy :: Proxy (Tree.Tree a))))
]))
flowTypeName _ = Just "Tree"
instance FlowTyped () where
isPrim _ = False
flowType _ = Fix (Tuple V.empty)
flowTypeName _ = Nothing
$(concat <$> mapM
(\ty ->
[d|
instance FlowTyped $ty where
isPrim _ = False
flowType _ = Fix (Prim Number)
flowTypeName _ = Nothing |])
[ [t|Int|], [t|Int8|], [t|Int16|], [t|Int32|], [t|Int64|]
, [t|Word|], [t|Word8|], [t|Word16|], [t|Word32|], [t|Word64|]
, [t|Float|], [t|Double|], [t|Scientific|]
])