aeson-flowtyped-0.12.2: src/Data/Aeson/Flow.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
-- | Derive <https://flow.org/ Flow types> using aeson 'Options'.
--
-- Does not currently support the 'unwrapUnaryRecords' option.
module Data.Aeson.Flow
( -- * AST types
FlowTyped (..)
, callType
, FlowTypeF
, FlowType
-- , Fix (..)
, pattern FObject
, pattern FExactObject
, pattern FObjectMap
, pattern FArray
, pattern FTuple
, pattern FLabelledTuple
, pattern FFun
, pattern FAlt
, pattern FPrim
, pattern FPrimBoolean
, pattern FPrimNumber
, pattern FPrimString
, pattern FPrimBottom
, pattern FPrimMixed
, pattern FPrimUnknown
, pattern FPrimNull
, pattern FPrimNever
, pattern FPrimUndefined
, pattern FPrimAny
, pattern FNullable
, pattern FOmitable
, pattern FLiteral
, pattern FTag
, pattern FName
, pattern FGenericParam
, pattern FCallType
-- * Code generation
-- ** Wholesale ES6/flow modules
, Export
, export
, RenderMode (..)
, RenderOptions (..)
, ModuleOptions (..)
, typeScriptModuleOptions
, flowModuleOptions
, generateModule
, writeModule
, showTypeAs
, exportTypeAs
-- ** TS specific
, showTypeScriptType
-- ** Flow specific
, showFlowType
-- * Dependencies
, exportsDependencies
, dependencies
-- * Utility
, FlowCallable
, FlowName (..)
, Flowable (..)
, FlowTyFields (..)
, FlowDeconstructField
, Typeable
, typeRep
) where
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Reader
import qualified Data.Aeson as A
import Data.Aeson.Types (Options (..),
SumEncoding (..))
import Data.Eq.Deriving (deriveEq1)
import Data.Fix (Fix (..))
import Data.Fixed (Fixed)
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.IntMap.Strict as I
import qualified Data.IntSet as IntSet
import Data.Kind (Type)
import Data.List (foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Semigroup hiding (Any)
import Data.Proxy
import Data.Reflection
import Data.Scientific (Scientific)
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
import qualified Type.Reflection as TR
import Debug.Trace
-- | The main AST for flowtypes.
data FlowTypeF a
= Object !(HashMap Text a)
| ExactObject !(HashMap Text a)
| ObjectMap !Text a a
| Array a
| Tuple !(Vector a)
| LabelledTuple !(Vector (Maybe Text, a))
| Fun !(Vector (Text, a)) a
| Alt a a
| Prim !PrimType
| Nullable a
| Omitable a -- ^ omitable when null or undefined
| Literal !A.Value
| Tag !Text
| GenericParam !Int
| CallType !FlowName [a]
| SomeFlowType !Flowable
deriving (Show, Eq, Functor, Traversable, Foldable)
-- | A primitive flow/javascript type
data PrimType
= Boolean
| Number
| String
| Null
| Undefined
| Bottom -- ^ uninhabited type; @never@ in typescript, and @empty@ in flow
| Mixed -- ^ @unknown@ in typescript, @mixed@ in flow
| Any
deriving (Show, Read, Eq, Ord)
-- | A name for a flowtyped data-type. These are returned by 'dependencies'.
data FlowName where
FlowName :: (FlowCallable a) => Proxy a -> Text -> FlowName
data Flowable where
Flowable :: (FlowCallable a) => Proxy a -> Flowable
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
--------------------------------------------------------------------------------
-- Magical newtype for injecting showsPrec into any arbitrary Show
inj :: Proxy s -> a -> Inj s a
inj _ = Inj
newtype Inj s a = Inj a
-- needs UndecidableInstances
instance Reifies s (Int -> a -> ShowS) => Show (Inj s a) where
showsPrec i (Inj a) = reflect (Proxy :: Proxy s) i a
--------------------------------------------------------------------------------
data RenderMode = RenderTypeScript | RenderFlow
deriving (Eq, Show)
data RenderOptions = RenderOptions
{ renderMode :: !RenderMode
} deriving (Eq, Show)
instance Show FlowName where
show (FlowName _ t) = show t
instance Eq FlowName where
FlowName (t0 :: Proxy t0) n0 == FlowName (t1 :: Proxy t1) n1 =
case eqT :: Maybe (t0 :~: t1) of
Just Refl -> (t0, n0) == (t1, n1)
Nothing -> False
instance Ord FlowName where
FlowName t0 n0 `compare` FlowName t1 n1 = n0 `compare` n1
-- XXX this breaks using (typeRep t0, n0) `compare` (typeRep t1, n1) for some
-- reason... dunno why
instance Show Flowable where
show (Flowable t) = show (typeRep t)
instance Eq Flowable where
Flowable a == Flowable b = typeRep a == typeRep b
instance Ord Flowable where
Flowable a `compare` Flowable b = typeRep a `compare` typeRep b
-- XXX: vector >= 0.12 has Eq1 vector which allows us to use eq for Fix
-- FlowTypeF and related types
--------------------------------------------------------------------------------
pattern FObject :: HashMap Text FlowType -> FlowType
pattern FObject x = Fix (Object x)
pattern FExactObject :: HashMap Text FlowType -> FlowType
pattern FExactObject x = Fix (ExactObject x)
pattern FObjectMap :: Text -> FlowType -> FlowType -> FlowType
pattern FObjectMap keyName keyType vals = Fix (ObjectMap keyName keyType vals)
pattern FArray :: FlowType -> FlowType
pattern FArray a = Fix (Array a)
pattern FTuple :: Vector FlowType -> FlowType
pattern FTuple a = Fix (Tuple a)
pattern FLabelledTuple :: Vector (Maybe Text, FlowType) -> FlowType
pattern FLabelledTuple a = Fix (LabelledTuple a)
pattern FFun :: Vector (Text, FlowType) -> FlowType -> FlowType
pattern FFun v t = Fix (Fun v t)
pattern FAlt :: FlowType -> FlowType -> FlowType
pattern FAlt a b = Fix (Alt a b)
pattern FPrim :: PrimType -> FlowType
pattern FPrim a = Fix (Prim a)
pattern FPrimBoolean :: FlowType
pattern FPrimBoolean = FPrim Boolean
pattern FPrimNumber :: FlowType
pattern FPrimNumber = FPrim Number
pattern FPrimString :: FlowType
pattern FPrimString = FPrim String
pattern FPrimBottom :: FlowType
pattern FPrimBottom = FPrim Bottom
pattern FPrimMixed :: FlowType
pattern FPrimMixed = FPrim Mixed
pattern FPrimUnknown :: FlowType
pattern FPrimUnknown = FPrim Mixed
pattern FPrimAny :: FlowType
pattern FPrimAny = FPrim Any
pattern FPrimNever :: FlowType
pattern FPrimNever = FPrim Bottom
pattern FPrimNull :: FlowType
pattern FPrimNull = FPrim Null
pattern FPrimUndefined :: FlowType
pattern FPrimUndefined = FPrim Undefined
pattern FNullable :: FlowType -> FlowType
pattern FNullable a = Fix (Nullable a)
pattern FOmitable :: FlowType -> FlowType
pattern FOmitable a = Fix (Omitable a)
pattern FLiteral :: A.Value -> FlowType
pattern FLiteral a = Fix (Literal a)
pattern FTag :: Text -> FlowType
pattern FTag a = Fix (Tag a)
pattern FName :: FlowName -> FlowType
pattern FName a = Fix (CallType a [])
pattern FGenericParam :: Int -> FlowType
pattern FGenericParam a = Fix (GenericParam a)
pattern FCallType :: FlowName -> [FlowType] -> FlowType
pattern FCallType f xs = Fix (CallType f xs)
--------------------------------------------------------------------------------
instance Show1 FlowTypeF where
liftShowsPrec sp sl i a =
liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a)))
data GFlowInfo a = Constr !Text GFlowTypeI a | NoInfo a
deriving (Show, Functor, Traversable, Foldable)
instance Show1 (Showy GFlowInfo) where
liftShowsPrec _ _ i (Showy a) = showsPrec i a
instance Show1 GFlowInfo where
liftShowsPrec sp sl i a =
liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a)))
type GFlowTypeI = Fix (GFlowInfo `Compose` FlowTypeF)
type FlowType = Fix FlowTypeF
text :: Text -> PP.Doc
text = PP.text . T.unpack
squotes :: Text -> PP.Doc
squotes = PP.squotes . text . T.replace "'" "\\'"
type Poly = ReaderT RenderOptions (Reader [Flowable])
ppAlts :: [FlowType] -> FlowType -> Poly PP.Doc
ppAlts alts (Fix f) = case f of
Alt a b -> ppAlts (a:alts) b
x -> PP.align . sep <$> mapM 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 -> squotes 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 -> Poly [PP.Doc]
ppObject = mapM ppField . H.toList
where
ppField (name, fty) = do
case fty of
Fix (Omitable fty') ->
-- key?: type
(\fty'' -> text name PP.<> PP.text "?" PP.<> PP.colon PP.<+> fty'') <$> pp fty'
fty' ->
-- key: type
(\fty'' -> text name PP.<> PP.colon PP.<+> fty'') <$> pp fty'
polyVarNames :: [Text]
polyVarNames =
map T.singleton ['A'..'Z'] ++
zipWith (\i t -> t `T.append` T.pack (show i)) [0 :: Int ..] polyVarNames
pp :: FlowType -> Poly PP.Doc
pp (Fix ft) = case ft of
ObjectMap keyName keyType a ->
(\r -> braceList
[ PP.brackets (text keyName PP.<> PP.text ": string") PP.<>
PP.colon PP.<+>
r
]) <$> pp a
Object hm ->
braceList <$> ppObject hm
ExactObject hm -> do
mode <- asks renderMode
case mode of
RenderFlow -> braceBarList <$> ppObject hm
RenderTypeScript -> braceList <$> ppObject hm
-- x[]
Array a ->
(\r -> mayWrap a r PP.<> PP.string "[]") <$> pp a
-- [x, y, z]
Tuple t ->
PP.list <$> mapM pp (V.toList t)
-- [l1: x, y, l2: z]
LabelledTuple t -> PP.list <$> mapM
(\(mlbl, ty) -> case mlbl of
Just lbl -> ((text lbl PP.<> PP.string ":") PP.<+>) <$> pp ty
Nothing -> pp ty)
(V.toList t)
Alt a b ->
ppAlts [a] b
Prim pt -> do
mode <- asks renderMode
return $ case pt of
Boolean -> PP.text "boolean"
Number -> PP.text "number"
String -> PP.text "string"
Null -> PP.text "null"
Undefined -> PP.text "undefined"
Any -> PP.text "any"
Mixed -> case mode of
RenderFlow -> PP.text "mixed"
RenderTypeScript -> PP.text "unknown"
Bottom -> case mode of
RenderFlow -> PP.text "empty"
RenderTypeScript -> PP.text "never"
Nullable a ->
-- n.b. there is no 'undefined' in json. void is undefined | null in both ts
-- and flow (and ?x syntax for void|x)
(\a' -> PP.text "null" PP.<+> PP.string "|" PP.<+> a') <$> pp a
Omitable a ->
pp (FNullable a)
Literal a ->
return (ppJson a)
Tag t ->
return (squotes t)
GenericParam ix ->
return (text (polyVarNames !! ix))
{-
opts <- ask
params <- lift ask
let ft | ix < length params = case params !! ix of
Flowable p -> callType p
| otherwise = FPrimNever
let r = runReaderT (pp ft) opts `runReader` []
return r
-}
CallType (FlowName _ t) [] ->
return (text t)
CallType (FlowName _ t) args -> do
vs <- mapM pp args
return (text t PP.<> PP.angles (PP.hsep (PP.punctuate PP.comma vs)))
_ ->
return (PP.string (show ft))
-- | Pretty-print a flowtype in flowtype syntax
renderTypeWithOptions :: RenderOptions -> FlowType -> [Flowable] -> PP.Doc
renderTypeWithOptions opts ft params =
(pp ft `runReaderT` opts) `runReader` params
-- | Pretty-print a flowtype in flowtype syntax
showFlowType :: FlowType -> [Flowable] -> Text
showFlowType ft params =
T.pack . show $ renderTypeWithOptions RenderOptions{renderMode=RenderFlow} ft params
-- | Pretty-print a flowtype in flowtype syntax
showTypeScriptType :: FlowType -> [Flowable] -> Text
showTypeScriptType ft params =
T.pack . show $ renderTypeWithOptions RenderOptions{renderMode=RenderTypeScript} ft params
--------------------------------------------------------------------------------
-- Module exporting
-- | Generate a @ export type @ declaration.
exportTypeAs :: RenderOptions -> Text -> FlowType -> [Flowable] -> Text
exportTypeAs opts = showTypeAs opts True
-- | Generate a @ type @ declaration, possibly an export.
showTypeAs :: RenderOptions -> Bool -> Text -> FlowType -> [Flowable] -> Text
showTypeAs opts isExport name ft params =
T.pack . render $
PP.string (if isExport then "export type " else "type ")
PP.<> text name
PP.<> renderedParams
PP.<+> text "="
PP.<+> PP.indent 2 renderedTypeDecl
PP.<> text ";"
PP.<> PP.linebreak
where
renderedTypeDecl = renderTypeWithOptions opts ft params
renderedParams
| null params = mempty
| otherwise =
PP.angles (PP.hsep
(PP.punctuate PP.comma
(map text (take (length params) polyVarNames))))
render = ($[]) . PP.displayS . PP.renderPretty 1.0 80
-- | Compute all the dependencies of a 'FlowTyped' thing, including itself.
dependencies :: (FlowCallable a) => Proxy a -> Set.Set FlowName
dependencies p0 =
(case flowTypeName p0 of
Just t -> Set.insert (FlowName p0 t)
Nothing -> id)
(M.foldl' Set.union Set.empty (transitiveDeps (Flowable p0) M.empty))
where
flowNameToFlowable (FlowName fn _) = Flowable fn
immediateDeps :: FlowType -> Set.Set FlowName
immediateDeps (FCallType n tys) = Set.insert n (Set.unions (map immediateDeps tys))
immediateDeps (Fix p) = foldMap immediateDeps p
transitiveDeps
:: Flowable
-> M.Map Flowable (Set.Set FlowName)
-> M.Map Flowable (Set.Set FlowName)
transitiveDeps fpf@(Flowable p) acc
| fpf `M.notMember` acc =
let
imms = immediateDeps (flowType p)
withThis = M.insert fpf imms acc
in
Set.foldr' (\x xs -> transitiveDeps (flowNameToFlowable x) xs) withThis imms
| otherwise = acc
data ModuleOptions = ModuleOptions
{ -- | You might want to change this to include e.g. flow-runtime
pragmas :: [Text]
, header :: [Text]
, exportDeps :: Bool
, computeDeps :: Bool
, renderOptions :: RenderOptions
} deriving (Eq, Show)
flowModuleOptions :: ModuleOptions
flowModuleOptions = ModuleOptions
{ pragmas = ["// @flow"]
, header = ["This module has been generated by aeson-flowtyped."]
, exportDeps = True
, computeDeps = True
, renderOptions = RenderOptions{renderMode = RenderFlow}
}
typeScriptModuleOptions :: ModuleOptions
typeScriptModuleOptions = ModuleOptions
{ pragmas = []
, header = ["This module has been generated by aeson-flowtyped."]
, exportDeps = True
, computeDeps = True
, renderOptions = RenderOptions{renderMode = RenderTypeScript}
}
data Export where
Export :: FlowCallable a => Proxy a -> Export
export :: forall a. FlowCallable a => Export
export = Export (Proxy :: Proxy a)
instance Eq Export where
Export p0 == Export p1 =
flowTypeName p0 == flowTypeName p1 ||
typeRep p0 == typeRep p1
exportsDependencies :: [Export] -> Set.Set FlowName
exportsDependencies = foldMap $ \e -> case e of
Export a -> dependencies a
generateModule :: ModuleOptions -> [Export] -> Text
generateModule opts exports = T.unlines $
(\m -> (pragmas opts ++ map ("// " `T.append`) (header opts)) ++
(T.empty : m))
. map flowDecl
. flowNames
$ exports
where
flowNames =
if computeDeps opts
then Set.toList . exportsDependencies
else catMaybes . map (\ex -> case ex of
Export p -> FlowName p <$> flowTypeName p)
flowDecl (FlowName p name) =
if Export p `elem` exports || exportDeps opts
then showTypeAs (renderOptions opts) True name (flowType p) (flowTypeVars p)
else showTypeAs (renderOptions opts) False name (flowType p) (flowTypeVars p)
writeModule :: ModuleOptions -> FilePath -> [Export] -> IO ()
writeModule opts path =
TIO.writeFile path . generateModule opts
--------------------------------------------------------------------------------
-- | 'flowType' using 'Generic'
defaultFlowType :: (Generic a, GFlowTyped (Rep a)) => Options -> Proxy a -> FlowType
defaultFlowType opt p
| unwrapUnaryRecords opt = error "aeson-flowtype does not yet support the unwrapUnaryRecords option."
| otherwise = gflowType opt (fmap from p)
-- | 'flowTypeName' using 'Generic'
defaultFlowTypeName
:: (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name)
=> Proxy a
-> Maybe Text
defaultFlowTypeName p
= Just
. cleanup
. T.pack
. symbolVal
. pGetName
. fmap from
$ p
where
pGetName :: Proxy (D1 ('MetaData name mod pkg t) c x) -> Proxy name
pGetName _ = Proxy
cleanup = T.replace "'" "_" -- I think this is the only illegal token in JS
-- that's allowed in Haskell, other than type
-- operators... TODO, rename type operators
callType' :: (FlowCallable a) => Proxy a -> [FlowType] -> FlowType
callType' p args = case flowTypeName p of
Just n -> FCallType (FlowName p n) args
Nothing -> flowType p
where
vars = flowTypeVars p
callType :: forall a. FlowCallable a => Proxy a -> FlowType
callType p = callType' p (map (\(Flowable t) -> callType t) (flowTypeVars p))
type FlowCallable a = (Typeable a, FlowTyped a)
class FlowTyped a where
flowType :: Proxy a -> FlowType
flowTypeName :: Proxy a -> Maybe Text
flowTypeVars :: Proxy a -> [Flowable]
flowTypeVars _ = []
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
data Param (p :: Nat) = Param
--------------------------------------------------------------------------------
type family FlowDeconstructField (k :: t) :: (Symbol, Type)
type instance FlowDeconstructField '(a, b) = '(a, b)
-- | Useful for declaring flowtypes from type-level key/value sets, like
--
-- @
-- FlowTyFields :: FlowTyFields Person '['("name", String), '("email", String)]
-- @
data FlowTyFields :: Type -> [k] -> Type where
FlowTyFields :: FlowTyFields k fs
class ReifyFlowTyFields a where
reifyFlowTyFields :: Proxy a -> HashMap Text FlowType -> HashMap Text FlowType
instance ReifyFlowTyFields '[] where
reifyFlowTyFields _ = id
instance ( FlowDeconstructField x ~ '(k, v)
, KnownSymbol k
, FlowTyped v
, ReifyFlowTyFields xs
) =>
ReifyFlowTyFields (x:xs) where
reifyFlowTyFields _ acc =
reifyFlowTyFields (Proxy :: Proxy xs) $!
H.insert
(T.pack (symbolVal (Proxy :: Proxy k)))
(flowType (Proxy :: Proxy v))
acc
instance (FlowTyped a, ReifyFlowTyFields fs) => FlowTyped (FlowTyFields a fs) where
flowType _ = FExactObject (reifyFlowTyFields (Proxy :: Proxy fs) H.empty)
flowTypeName _ = flowTypeName (Proxy :: Proxy a)
--------------------------------------------------------------------------------
class GFlowTyped g where
gflowType :: Options -> Proxy (g x) -> FlowType
class GFlowVal g where
gflowVal :: Options -> Proxy (g x) -> GFlowTypeI
instance (KnownSymbol name, GFlowVal c) =>
GFlowTyped (D1 ('MetaData name mod pkg t) c) where
gflowType opt _ = runFlowI (postprocess (gflowVal opt (Proxy :: Proxy (c x))))
where
postprocess :: GFlowTypeI -> GFlowTypeI
postprocess i
#if MIN_VERSION_aeson(1,2,0)
| not (tagSingleConstructors opt), Just o <- removeSingleConstructorTag i =
o
#endif
| 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
#if MIN_VERSION_aeson(1,2,0)
removeSingleConstructorTag :: GFlowTypeI -> Maybe GFlowTypeI
removeSingleConstructorTag (FC (Info (ExactObject hm))) =
case sumEncoding opt of
TaggedObject tfn _ ->
Just (FC (Info (ExactObject (H.delete (T.pack tfn) hm))))
_ ->
Nothing
removeSingleConstructorTag _ =
Nothing
#endif
-- no-field constructors have a "contents" field of Prim Void
isNullary :: GFlowTypeI -> Bool
isNullary (FC (Info (Prim a))) = case a of
Bottom -> True
Null -> True
Undefined -> True
_ -> False
isNullary _ = False
-- try to detect if the type is a bunch of single-constructor
-- alternatives
--
-- XXX: this should preserve the order in which they are declared
-- ... but does it?
go :: [Text] -> GFlowTypeI -> 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 :: GFlowTypeI -> 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 GFlowInfo f)) -> Fix (Compose GFlowInfo f)
noInfo = Fix . Compose . NoInfo
infoConstr :: Text -> GFlowTypeI -> f (Fix (Compose GFlowInfo f)) -> Fix (Compose GFlowInfo f)
infoConstr tag nxt = Fix . Compose . Constr tag nxt
discardInfo :: GFlowInfo a -> a
discardInfo (NoInfo a) = a
discardInfo (Constr _ _ a) = a
pattern Info :: a -> GFlowInfo 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
| H.size next == 1 = head (H.elems next)
| otherwise = 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 $ \t -> case t of
FNullable a -> FOmitable a
_ -> t
else traceShow opt 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 FlowCallable r => GFlowVal (Rec0 r) where
gflowVal _opt (p :: r' x) =
cata noInfo (callType (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 Undefined)
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
--------------------------------------------------------------------------------
-- Instances
instance (FlowCallable a) => FlowTyped [a] where
flowType _ = FArray (callType (Proxy :: Proxy a))
isPrim _ = True
flowTypeName _ = Nothing
instance (FlowCallable a) => FlowTyped (Vector a) where
flowType _ = FArray (callType (Proxy :: Proxy a))
isPrim _ = True
flowTypeName _ = Nothing
instance (FlowCallable a) => FlowTyped (VU.Vector a) where
flowType _ = FArray (callType (Proxy :: Proxy a))
isPrim _ = True
flowTypeName _ = Nothing
instance (FlowCallable a) => FlowTyped (VS.Vector a) where
flowType _ = FArray (callType (Proxy :: Proxy a))
isPrim _ = True
flowTypeName _ = Nothing
instance ( FlowCallable a
, FlowCallable b
) => FlowTyped (a, b) where
flowTypeName _ = Nothing
flowType _ =
FTuple (V.fromList [aFt, bFt])
where
aFt = callType (Proxy :: Proxy a)
bFt = callType (Proxy :: Proxy b)
instance (FlowCallable a) => FlowTyped (Maybe a) where
flowType _ = FNullable (callType (Proxy :: Proxy a))
isPrim _ = True
flowTypeName _ = Nothing
instance ( FlowCallable a
, FlowCallable b) =>
FlowTyped (Either a b) where
flowTypeName _ = Nothing
flowType _ = FAlt
(FExactObject (H.fromList [("Left", aFt)]))
(FExactObject (H.fromList [("Right", bFt)]))
where
aFt = callType (Proxy :: Proxy a)
bFt = callType (Proxy :: Proxy b)
instance ( FlowCallable a
, FlowCallable b
, FlowCallable c) =>
FlowTyped (a, b, c) where
flowTypeName _ = Nothing
flowType _ = FTuple (V.fromList [aFt, bFt, cFt])
where
aFt = callType (Proxy :: Proxy a)
bFt = callType (Proxy :: Proxy b)
cFt = callType (Proxy :: Proxy c)
instance ( FlowCallable a
, FlowCallable b
, FlowCallable c
, FlowCallable d
) =>
FlowTyped (a, b, c, d) where
flowTypeName _ = Nothing
flowType _ = FTuple (V.fromList [aFt, bFt, cFt, dFt])
where
aFt = callType (Proxy :: Proxy a)
bFt = callType (Proxy :: Proxy b)
cFt = callType (Proxy :: Proxy c)
dFt = callType (Proxy :: Proxy d)
instance ( FlowCallable a
, FlowCallable b
, FlowCallable c
, FlowCallable d
, FlowCallable e
) =>
FlowTyped (a, b, c, d, e) where
flowTypeName _ = Nothing
flowType _ = FTuple (V.fromList [aFt, bFt, cFt, dFt, eFt])
where
aFt = callType (Proxy :: Proxy a)
bFt = callType (Proxy :: Proxy b)
cFt = callType (Proxy :: Proxy c)
dFt = callType (Proxy :: Proxy d)
eFt = callType (Proxy :: Proxy e)
instance FlowTyped Text where
isPrim _ = True
flowType _ = FPrimString
flowTypeName _ = Nothing
instance FlowTyped TL.Text where
isPrim _ = True
flowType _ = FPrimString
flowTypeName _ = Nothing
instance {-# OVERLAPS #-} FlowTyped String where
isPrim _ = True
flowType _ = FPrimString
flowTypeName _ = Nothing
instance FlowTyped Void.Void where
isPrim _ = True
flowType _ = FPrimBottom
flowTypeName _ = Nothing
instance FlowTyped Char where
isPrim _ = True
flowType _ = FPrimString
flowTypeName _ = Nothing
instance FlowTyped Bool where
isPrim _ = True
flowType _ = FPrimBoolean
flowTypeName _ = Nothing
instance FlowTyped A.Value where
isPrim _ = True
flowType _ = FPrimMixed
flowTypeName _ = Nothing
instance FlowTyped UTCTime where
isPrim _ = False
flowType _ = FPrimString
flowTypeName _ = Nothing
instance Typeable a => FlowTyped (Fixed a) where
isPrim _ = False
flowType _ = FPrimNumber
flowTypeName _ = Nothing
instance ( FlowCallable k
, FlowCallable a
, A.ToJSONKey k
) => FlowTyped (HashMap k a) where
-- XXX this is getting quite incoherent, what makes something "Prim" or not...
isPrim _ = True
flowType _ =
case A.toJSONKey :: A.ToJSONKeyFunction k of
A.ToJSONKeyText{} ->
FObjectMap "key" FPrimString (callType (Proxy :: Proxy a))
A.ToJSONKeyValue{} ->
FArray (FTuple (V.fromListN 2
[ callType (Proxy :: Proxy k)
, callType (Proxy :: Proxy a)
]))
flowTypeName _ =
Nothing
instance (FlowCallable a) => FlowTyped (Set.Set a) where
isPrim _ = False
flowType _ = FArray (callType (Proxy :: Proxy a))
flowTypeName _ = Nothing
instance FlowTyped IntSet.IntSet where
isPrim _ = False
flowType _ = FArray FPrimNumber -- (Fix (Prim Number))
flowTypeName _ = Nothing
instance (FlowCallable a) => FlowTyped (I.IntMap a) where
isPrim _ = False
flowType _ = Fix . Array . Fix . Tuple . V.fromListN 2 $
[ FPrimNumber
, callType (Proxy :: Proxy a)
]
flowTypeName _ = Nothing
instance (FlowCallable a) => FlowTyped (HashSet.HashSet a) where
isPrim _ = False
flowType _ = FArray (callType (Proxy :: Proxy a))
flowTypeName _ = Nothing
-- | This instance is defined recursively. You'll probably need to use
-- 'dependencies' to extract a usable definition
instance (FlowCallable a) => FlowTyped (Tree.Tree a) where
isPrim _ = False
flowType _ = FTuple
(V.fromList
[ FGenericParam 0
, FArray (callType' (Proxy :: Proxy (Tree.Tree a)) [FGenericParam 0])
])
flowTypeName _ = Just "Tree"
flowTypeVars _ = [Flowable (Proxy :: Proxy a)]
instance FlowTyped () where
isPrim _ = False
flowType _ = FTuple V.empty
flowTypeName _ = Nothing
-- monomorphic numeric instances
$(concat <$> mapM
(\ty ->
[d|
instance FlowTyped $ty where
isPrim _ = False
flowType _ = FPrimNumber
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|]
])
deriveEq1 ''FlowTypeF