aeson-flowtyped 0.13.2.1 → 0.14.0
raw patch · 3 files changed
+1158/−1220 lines, 3 filesdep ~aesondep ~basesetup-changed
Dependency ranges changed: aeson, base
Files
- Setup.hs +0/−2
- aeson-flowtyped.cabal +7/−7
- src/Data/Aeson/Flow.hs +1151/−1211
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
aeson-flowtyped.cabal view
@@ -1,10 +1,10 @@ name: aeson-flowtyped-version: 0.13.2.1+version: 0.14.0 synopsis: Create Flow or TypeScript type definitions from Haskell data types. description: Create Flow or TypeScript type definitions from Haskell data types. category: Web-homepage: https://github.com/mikeplus64/aeson-flowtyped#readme-bug-reports: https://github.com/mikeplus64/aeson-flowtyped/issues+homepage: https://gitlab.com/transportengineering/aeson-flowtyped#readme+bug-reports: https://gitlab.com/transportengineering/aeson-flowtyped/issues author: Mike Ledger <mike@quasimal.com> maintainer: mike@quasimal.com license: BSD3@@ -20,8 +20,8 @@ hs-source-dirs: src build-depends:- aeson >=0.8- , base >= 4.11 && < 4.17+ base >=4.11 && <4.18+ , aeson >=2.0 , containers , data-fix , deriving-compat@@ -50,9 +50,9 @@ hs-source-dirs: test build-depends:- aeson >=0.8+ base+ , aeson >=2.0 , aeson-flowtyped- , base , containers , data-fix , recursion-schemes
src/Data/Aeson/Flow.hs view
@@ -1,1213 +1,1153 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# 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/typescript modules- Export,- export,- RenderMode (..),- RenderOptions (..),- ModuleOptions (..),- typeScriptModuleOptions,- flowModuleOptions,- generateModule,- writeModule,- showTypeAs,- exportTypeAs,-- -- ** Convenience for generating flowtypes from other types- FlowTyFields (..),- FlowDeconstructField,-- -- ** TS specific- showTypeScriptType,-- -- ** Flow specific- showFlowType,-- -- * Dependencies- exportsDependencies,- dependencies,-- -- * Utility- FlowName (..),- Flowable (..),- defaultFlowTypeName,- defaultFlowType,- )-where--import Control.Monad.Reader-import Control.Monad.State.Strict-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.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 qualified Data.Map.Strict as M-import Data.Maybe-import qualified Data.Monoid as Monoid-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- ( D1,- Generic,- Meta (..),- Rep,- from,- )-import GHC.TypeLits-import qualified Generics.SOP as SOP-import qualified Generics.SOP.GGP as SOP-import qualified Text.PrettyPrint.Leijen as PP---- | 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 when null or undefined- Omitable a- | Literal !A.Value- | Tag !Text- | GenericParam !Int- | CallType !FlowName [a]- | SomeFlowType !Flowable- | TypeDoc !(Vector Text) a- deriving (Show, Eq, Functor, Traversable, Foldable)---- | A primitive flow/javascript type-data PrimType- = Boolean- | Number- | String- | Null- | Undefined- | -- | uninhabited type; @never@ in typescript, and @empty@ in flow- Bottom- | -- | @unknown@ in typescript, @mixed@ in flow- Mixed- | Any- deriving (Show, Read, Eq, Ord)---- | A name for a flowtyped data-type. These are returned by 'dependencies'.-data FlowName where- FlowName :: (FlowTyped a) => Proxy a -> Text -> FlowName--data Flowable where- Flowable :: (FlowTyped 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 n0 == FlowName _t1 n1 = n0 == 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)--pattern FTypeDoc :: Vector Text -> FlowType -> FlowType-pattern FTypeDoc f xs = Fix (TypeDoc f xs)------------------------------------------------------------------------------------instance Show1 FlowTypeF where- liftShowsPrec sp sl i a =- liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a)))--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 -> do- keyTy <- pp keyType- r <- pp a- pure- ( braceList- [ PP.brackets (text keyName PP.<> PP.text ":" PP.<+> keyTy)- PP.<> PP.colon- PP.<+> r- ]- )- 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))- 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)))- TypeDoc _doc t -> pp t- _ -> 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.<+> 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 :: (FlowTyped 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' (transitiveDeps . flowNameToFlowable) 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 :: FlowTyped a => Proxy a -> Export--export :: forall a. FlowTyped 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 (\(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 mapMaybe (\(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------------------------------------------------------------------------------------type family FlowDeconstructField (k :: t) :: (Symbol, *)--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 :: * -> [k] -> * 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 :: [k]), Typeable fs, Typeable k) => FlowTyped (FlowTyFields a fs) where- flowType _ = FExactObject (reifyFlowTyFields (Proxy :: Proxy fs) H.empty)- flowTypeName _ = flowTypeName (Proxy :: Proxy a)------------------------------------------------------------------------------------callType' :: (FlowTyped a) => Proxy a -> [FlowType] -> FlowType-callType' p args = case flowTypeName p of- Just n -> FCallType (FlowName p n) args- Nothing -> flowType p--callType :: forall a. FlowTyped a => Proxy a -> FlowType-callType p = callType' p (map (\(Flowable t) -> callType t) (flowTypeVars p))--class Typeable a => 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 ::- (SOP.GDatatypeInfo a, SOP.All2 FlowTyped (SOP.GCode a)) =>- Proxy a ->- FlowType- flowType p = flowTypeFromSOP (flowOptions p) (SOP.gdatatypeInfo p)-- default flowTypeName ::- (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name) =>- Proxy a ->- Maybe Text- flowTypeName = defaultFlowTypeName---- | 'flowType' using 'SOP.HasDatatypeInfo'-defaultFlowType ::- (SOP.HasDatatypeInfo a, SOP.All2 FlowTyped (SOP.Code a)) =>- Options ->- Proxy a ->- FlowType-defaultFlowType opts p = flowTypeFromSOP opts (SOP.datatypeInfo p)--flowTypeFromSOP ::- SOP.All2 FlowTyped ty => Options -> SOP.DatatypeInfo ty -> FlowType-flowTypeFromSOP opts di = case comments of- [] -> ft- _ -> FTypeDoc (V.fromList comments) ft- where- (ft, comments) =- ( case di of- SOP.ADT moduleName typeName constrInfos _strictness -> do- modify' (moduleComment moduleName :)- modify' (typeComment typeName :)- pure . foldr1 FAlt $! case constrsKind constrInfos 0 0 0 True of- SumRecords -> sumEncode constrInfos- SumConstructors -> sumEncode constrInfos- SumNullaryConstructors -> sumNullaryEncode constrInfos- SingleRecord -> singleEncode constrInfos- SingleConstructor -> singleEncode constrInfos- SingleNullaryConstructor -> [FTuple V.empty]- Unsupported ->- error $ "aeson-flowtyped: Unsupported type " ++ show typeName- SOP.Newtype moduleName typeName constrInfo -> do- modify' (moduleComment moduleName :)- modify' (typeComment typeName :)- case constrInfo of- (SOP.Constructor constrName :: SOP.ConstructorInfo '[x]) -> do- modify' (constrComment constrName :)- pure (callType (Proxy :: Proxy x))- SOP.Record constrName ((SOP.FieldInfo _fname :: SOP.FieldInfo x) SOP.:* SOP.Nil) ->- do- modify' (constrComment constrName :)- pure (callType (Proxy :: Proxy x))- )- `runState` []-- constrsKind ::- SOP.NP SOP.ConstructorInfo ty ->- -- | total number of record or plain constructors- Int ->- -- | number of record constructors- Int ->- -- | number of plain constructors- Int ->- -- | whether every constructor is nullary- Bool ->- ConstructorsKind- constrsKind SOP.Nil !total !recs !plains !allNullary- | recs == 1 && plains == 0 = SingleRecord- | plains == 1 && recs == 0 =- if allNullary- then SingleNullaryConstructor- else SingleConstructor- | recs == total && plains == 0 = SumRecords- | plains == total && recs == 0 =- if allNullary- then SumNullaryConstructors- else SumConstructors- | otherwise = Unsupported- constrsKind (constr SOP.:* rest) total recs plains allNullary =- case constr of- (SOP.Constructor {} :: SOP.ConstructorInfo flds) ->- constrsKind- rest- (total + 1)- recs- (plains + 1)- (allNullary && isNullary @flds)- (SOP.Record {} :: SOP.ConstructorInfo flds) ->- constrsKind- rest- (total + 1)- (recs + 1)- plains- (allNullary && isNullary @flds)- _ -> Unsupported-- sumEncode,- singleEncode,- sumNullaryEncode ::- SOP.All2 FlowTyped ty => SOP.NP SOP.ConstructorInfo ty -> [FlowType]- sumEncode constrsNP =- SOP.hcfoldMap- (Proxy :: Proxy (SOP.All FlowTyped))- ( \case- (SOP.Constructor constrName :: SOP.ConstructorInfo xs) ->- let value =- let tuple =- V.fromList- $! SOP.hcfoldMap- (Proxy :: Proxy FlowTyped)- (\(Proxy :: SOP.Proxy x) -> [callType (Proxy :: Proxy x)])- (SOP.hpure Proxy :: SOP.NP Proxy xs)- in case V.length tuple of- 1 -> V.head tuple- _ -> FTuple tuple-- hasContents =- Monoid.getAny- $! SOP.hcfoldMap- (Proxy :: Proxy SOP.Top)- (\_ -> Monoid.Any True)- (SOP.hpure Proxy :: SOP.NP Proxy xs)- in case sumEncoding opts of- TaggedObject (T.pack -> tagFld) contentsFld- | hasContents ->- [ FExactObject- ( H.fromList- [ (tagFld, renderConstrTag constrName),- (T.pack contentsFld, value)- ]- )- ]- | otherwise ->- [ FExactObject- (H.singleton tagFld (renderConstrTag constrName))- ]- UntaggedValue -> [value]- ObjectWithSingleField ->- [ FExactObject- ( H.fromList- [(T.pack (constructorTagModifier opts constrName), value)]- )- ]- TwoElemArray ->- [FTuple (V.fromListN 2 [renderConstrTag constrName, value])]- SOP.Record constrName flds ->- let fldsList :: H.HashMap Text FlowType- fldsList =- H.fromList- $! SOP.hcfoldMap- (Proxy :: Proxy FlowTyped)- ( \(SOP.FieldInfo fname :: SOP.FieldInfo x) ->- [ ( T.pack (fieldLabelModifier opts fname),- callType (Proxy :: Proxy x)- )- ]- )- flds- in case sumEncoding opts of- -- The contents field is not used here but the tag one is- TaggedObject (T.pack -> tagFld) _contentsFld ->- [ FExactObject- (H.insert tagFld (renderConstrTag constrName) fldsList)- ]- UntaggedValue -> [FExactObject fldsList]- ObjectWithSingleField ->- [ FExactObject- ( H.singleton- (T.pack (constructorTagModifier opts constrName))- (FExactObject fldsList)- )- ]- TwoElemArray ->- [ FTuple- ( V.fromListN- 2- [renderConstrTag constrName, FExactObject fldsList]- )- ]- SOP.Infix {} ->- error "aeson-flowtyped: Unsupported use of infix constructor"- )- constrsNP-- singleEncode (constr SOP.:* SOP.Nil) = case constr of- (SOP.Constructor _constrName :: SOP.ConstructorInfo xs) ->- [ FTuple . V.fromList- $! SOP.hcfoldMap- (Proxy :: Proxy FlowTyped)- (\(Proxy :: SOP.Proxy x) -> [callType (Proxy :: Proxy x)])- (SOP.hpure Proxy :: SOP.NP Proxy xs)- ]- SOP.Record _constrName flds ->- [ FExactObject- $! H.fromList- $! SOP.hcfoldMap- (Proxy :: Proxy FlowTyped)- ( \(SOP.FieldInfo fname :: SOP.FieldInfo x) ->- [ ( T.pack (fieldLabelModifier opts fname),- callType (Proxy :: Proxy x)- )- ]- )- flds- ]- SOP.Infix {} ->- error "aeson-flowtyped: Unsupported use of infix constructor"- singleEncode _ =- error "aeson-flowtyped: Errorneous detection of single constructor"-- sumNullaryEncode constrsNP- | allNullaryToStringTag opts =- [ FLiteral (A.String (T.pack (constructorTagModifier opts tag)))- | tag <-- SOP.hcfoldMap- (Proxy :: Proxy SOP.Top)- (\(SOP.Constructor constrName) -> [constrName])- constrsNP- ]- | otherwise =- [ nullarySumObject (T.pack (constructorTagModifier opts tag))- | tag <-- SOP.hcfoldMap- (Proxy :: Proxy SOP.Top)- (\(SOP.Constructor constrName) -> [constrName])- constrsNP- ]-- nullarySumObject tagValue = case sumEncoding opts of- TaggedObject (T.pack -> tagFld) _contentsFld ->- FExactObject (H.singleton tagFld (FLiteral (A.String tagValue)))- UntaggedValue -> FTuple V.empty- ObjectWithSingleField ->- FExactObject (H.singleton tagValue (FTuple V.empty))- TwoElemArray ->- FTuple (V.fromListN 2 [FLiteral (A.String tagValue), FTuple V.empty])-- renderConstrTag = FLiteral . A.String . T.pack . constructorTagModifier opts-- moduleComment s = T.concat ["Origin module: `", T.pack s, "`"]- typeComment s = T.concat ["Origin type: ", T.pack s]- constrComment s = T.concat ["Origin constructor: ", T.pack s]-- isNullary :: forall xs. SOP.SListI xs => Bool- isNullary = SOP.lengthSList (Proxy :: Proxy xs) == 0--data ConstructorsKind- = SumRecords- | SumConstructors- | SumNullaryConstructors- | SingleRecord- | SingleConstructor- | SingleNullaryConstructor- | Unsupported---- | 'flowTypeName' using 'Generic'-defaultFlowTypeName ::- (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name) =>- Proxy a ->- Maybe Text-defaultFlowTypeName =- Just . cleanup . T.pack . symbolVal . pGetName . fmap from- 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------------------------------------------------------------------------------------- Instances--instance (FlowTyped a) => FlowTyped [a] where- flowType _ = FArray (callType (Proxy :: Proxy a))- isPrim _ = True- flowTypeName _ = Nothing--instance (FlowTyped a) => FlowTyped (Vector a) where- flowType _ = FArray (callType (Proxy :: Proxy a))- isPrim _ = True- flowTypeName _ = Nothing--instance (FlowTyped a) => FlowTyped (VU.Vector a) where- flowType _ = FArray (callType (Proxy :: Proxy a))- isPrim _ = True- flowTypeName _ = Nothing--instance (FlowTyped a) => FlowTyped (VS.Vector a) where- flowType _ = FArray (callType (Proxy :: Proxy a))- isPrim _ = True- flowTypeName _ = Nothing--instance- ( FlowTyped a,- FlowTyped 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 (FlowTyped a) => FlowTyped (Maybe a) where- flowType _ = FNullable (callType (Proxy :: Proxy a))- isPrim _ = True- flowTypeName _ = Nothing--instance- ( FlowTyped a,- FlowTyped 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- ( FlowTyped a,- FlowTyped b,- FlowTyped 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- ( FlowTyped a,- FlowTyped b,- FlowTyped c,- FlowTyped 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- ( FlowTyped a,- FlowTyped b,- FlowTyped c,- FlowTyped d,- FlowTyped 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 :: k), Typeable k) => FlowTyped (Fixed a) where- isPrim _ = False- flowType _ = FPrimNumber- flowTypeName _ = Nothing--instance- ( FlowTyped k,- FlowTyped 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 (FlowTyped 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 (FlowTyped a) => FlowTyped (I.IntMap a) where- isPrim _ = False- flowType _ =- Fix- . Array- . Fix- . Tuple- . V.fromListN 2- $ [FPrimNumber, callType (Proxy :: Proxy a)]- flowTypeName _ = Nothing--instance (FlowTyped 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 (FlowTyped 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|],- [t|Integer|]- ]- )+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# 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/typescript modules+ , Export+ , export+ , RenderMode(..)+ , RenderOptions(..)+ , ModuleOptions(..)+ , typeScriptModuleOptions+ , flowModuleOptions+ , generateModule+ , writeModule+ , showTypeAs+ , exportTypeAs+ -- ** Convenience for generating flowtypes from other types+ , FlowTyFields(..)+ , FlowDeconstructField+ -- ** TS specific+ , showTypeScriptType+ -- ** Flow specific+ , showFlowType+ -- * Dependencies+ , exportsDependencies+ , dependencies+ -- * Utility+ , FlowName(..)+ , Flowable(..)+ , defaultFlowTypeName+ , defaultFlowType+ ) where+import Control.Monad.Reader+import Control.Monad.State.Strict+import qualified Data.Aeson as A+import qualified Data.Aeson.Key as AK+import qualified Data.Aeson.KeyMap as AKM+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.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 qualified Data.Map.Strict as M+import Data.Maybe+import qualified Data.Monoid as Monoid+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 ( D1+ , Generic+ , Meta(..)+ , Rep+ , from+ )+import GHC.TypeLits+import qualified Generics.SOP as SOP+import qualified Generics.SOP.GGP as SOP+import qualified Text.PrettyPrint.Leijen as PP++-- | 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+ | TypeDoc !(Vector Text) a+ 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 ::(FlowTyped a) => Proxy a -> Text -> FlowName++data Flowable where+ Flowable ::(FlowTyped 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 n0 == FlowName _t1 n1 = n0 == 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)++pattern FTypeDoc :: Vector Text -> FlowType -> FlowType+pattern FTypeDoc f xs = Fix (TypeDoc f xs)++--------------------------------------------------------------------------------++instance Show1 FlowTypeF where+ liftShowsPrec sp sl i a =+ liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a)))++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 (AK.toText name)+ PP.<+> PP.colon+ PP.<+> ppJson fty+ PP.<> PP.space+ )+ (AKM.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 -> do+ keyTy <- pp keyType+ r <- pp a+ pure+ (braceList+ [ PP.brackets (text keyName PP.<> PP.text ":" PP.<+> keyTy)+ PP.<> PP.colon+ PP.<+> r+ ]+ )++ 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))++ 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)))++ TypeDoc _doc t -> pp t++ _ -> 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.<+> 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 :: (FlowTyped 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' (transitiveDeps . flowNameToFlowable) 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 ::FlowTyped a => Proxy a -> Export++export :: forall a . FlowTyped 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++--------------------------------------------------------------------------------++type family FlowDeconstructField (k :: t) :: (Symbol, *)+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 :: * -> [k] -> * 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 :: [k]), Typeable fs, Typeable k) => FlowTyped (FlowTyFields a fs) where+ flowType _ = FExactObject (reifyFlowTyFields (Proxy :: Proxy fs) H.empty)+ flowTypeName _ = flowTypeName (Proxy :: Proxy a)++--------------------------------------------------------------------------------++callType' :: (FlowTyped a) => Proxy a -> [FlowType] -> FlowType+callType' p args = case flowTypeName p of+ Just n -> FCallType (FlowName p n) args+ Nothing -> flowType p++callType :: forall a . FlowTyped a => Proxy a -> FlowType+callType p = callType' p (map (\(Flowable t) -> callType t) (flowTypeVars p))++class Typeable a => 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+ :: (SOP.GDatatypeInfo a, SOP.All2 FlowTyped (SOP.GCode a))+ => Proxy a+ -> FlowType+ flowType p = flowTypeFromSOP (flowOptions p) (SOP.gdatatypeInfo p)++ default flowTypeName+ :: (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name)+ => Proxy a+ -> Maybe Text+ flowTypeName = defaultFlowTypeName++-- | 'flowType' using 'SOP.HasDatatypeInfo'+defaultFlowType+ :: (SOP.HasDatatypeInfo a, SOP.All2 FlowTyped (SOP.Code a))+ => Options+ -> Proxy a+ -> FlowType+defaultFlowType opts p = flowTypeFromSOP opts (SOP.datatypeInfo p)++flowTypeFromSOP+ :: SOP.All2 FlowTyped ty => Options -> SOP.DatatypeInfo ty -> FlowType+flowTypeFromSOP opts di = case comments of+ [] -> ft+ _ -> FTypeDoc (V.fromList comments) ft+ where+ (ft, comments) =+ (case di of+ SOP.ADT moduleName typeName constrInfos _strictness -> do+ modify' (moduleComment moduleName :)+ modify' (typeComment typeName :)+ pure . foldr1 FAlt $! case constrsKind constrInfos 0 0 0 True of+ SumRecords -> sumEncode constrInfos+ SumConstructors -> sumEncode constrInfos+ SumNullaryConstructors -> sumNullaryEncode constrInfos+ SingleRecord -> singleEncode constrInfos+ SingleConstructor -> singleEncode constrInfos+ SingleNullaryConstructor -> [FTuple V.empty]+ Unsupported ->+ error $ "aeson-flowtyped: Unsupported type " ++ show typeName++ SOP.Newtype moduleName typeName constrInfo -> do+ modify' (moduleComment moduleName :)+ modify' (typeComment typeName :)+ case constrInfo of++ (SOP.Constructor constrName :: SOP.ConstructorInfo '[x]) -> do+ modify' (constrComment constrName :)+ pure (callType (Proxy :: Proxy x))++ SOP.Record constrName ((SOP.FieldInfo _fname :: SOP.FieldInfo x) SOP.:* SOP.Nil)+ -> do+ modify' (constrComment constrName :)+ pure (callType (Proxy :: Proxy x))+ )+ `runState` []++ constrsKind+ :: SOP.NP SOP.ConstructorInfo ty+ -> Int -- ^ total number of record or plain constructors+ -> Int -- ^ number of record constructors+ -> Int -- ^ number of plain constructors+ -> Bool -- ^ whether every constructor is nullary+ -> ConstructorsKind+ constrsKind SOP.Nil !total !recs !plains !allNullary+ | recs == 1 && plains == 0 = SingleRecord+ | plains == 1 && recs == 0 = if allNullary+ then SingleNullaryConstructor+ else SingleConstructor+ | recs == total && plains == 0 = SumRecords+ | plains == total && recs == 0 = if allNullary+ then SumNullaryConstructors+ else SumConstructors+ | otherwise = Unsupported+ constrsKind (constr SOP.:* rest) total recs plains allNullary =+ case constr of+ (SOP.Constructor{} :: SOP.ConstructorInfo flds) -> constrsKind+ rest+ (total + 1)+ recs+ (plains + 1)+ (allNullary && isNullary @flds)++ (SOP.Record{} :: SOP.ConstructorInfo flds) -> constrsKind+ rest+ (total + 1)+ (recs + 1)+ plains+ (allNullary && isNullary @flds)++ _ -> Unsupported++ sumEncode, singleEncode, sumNullaryEncode+ :: SOP.All2 FlowTyped ty => SOP.NP SOP.ConstructorInfo ty -> [FlowType]+ sumEncode constrsNP = SOP.hcfoldMap+ (Proxy :: Proxy (SOP.All FlowTyped))+ (\case+ (SOP.Constructor constrName :: SOP.ConstructorInfo xs) ->+ let+ value =+ let tuple = V.fromList $! SOP.hcfoldMap+ (Proxy :: Proxy FlowTyped)+ (\(Proxy :: SOP.Proxy x) -> [callType (Proxy :: Proxy x)])+ (SOP.hpure Proxy :: SOP.NP Proxy xs)+ in case V.length tuple of+ 1 -> V.head tuple+ _ -> FTuple tuple++ hasContents = Monoid.getAny $! SOP.hcfoldMap+ (Proxy :: Proxy SOP.Top)+ (\_ -> Monoid.Any True)+ (SOP.hpure Proxy :: SOP.NP Proxy xs)+ in+ case sumEncoding opts of+ TaggedObject (T.pack -> tagFld) contentsFld+ | hasContents+ -> [ FExactObject+ (H.fromList+ [ (tagFld, renderConstrTag constrName)+ , (T.pack contentsFld, value)+ ]+ )+ ]+ | otherwise+ -> [ FExactObject+ (H.singleton tagFld (renderConstrTag constrName))+ ]+ UntaggedValue -> [value]+ ObjectWithSingleField ->+ [ FExactObject+ (H.fromList+ [(T.pack (constructorTagModifier opts constrName), value)]+ )+ ]+ TwoElemArray ->+ [FTuple (V.fromListN 2 [renderConstrTag constrName, value])]++ SOP.Record constrName flds ->+ let+ fldsList :: H.HashMap Text FlowType+ fldsList =+ H.fromList+ $! SOP.hcfoldMap+ (Proxy :: Proxy FlowTyped)+ (\(SOP.FieldInfo fname :: SOP.FieldInfo x) ->+ [ ( T.pack (fieldLabelModifier opts fname)+ , callType (Proxy :: Proxy x)+ )+ ]+ )+ flds+ in+ case sumEncoding opts of+ -- The contents field is not used here but the tag one is+ TaggedObject (T.pack -> tagFld) _contentsFld ->+ [ FExactObject+ (H.insert tagFld (renderConstrTag constrName) fldsList)+ ]+ UntaggedValue -> [FExactObject fldsList]+ ObjectWithSingleField ->+ [ FExactObject+ (H.singleton+ (T.pack (constructorTagModifier opts constrName))+ (FExactObject fldsList)+ )+ ]+ TwoElemArray ->+ [ FTuple+ (V.fromListN+ 2+ [renderConstrTag constrName, FExactObject fldsList]+ )+ ]+ SOP.Infix{} ->+ error "aeson-flowtyped: Unsupported use of infix constructor"+ )+ constrsNP++ singleEncode (constr SOP.:* SOP.Nil) = case constr of+ (SOP.Constructor _constrName :: SOP.ConstructorInfo xs) ->+ [ FTuple . V.fromList $! SOP.hcfoldMap+ (Proxy :: Proxy FlowTyped)+ (\(Proxy :: SOP.Proxy x) -> [callType (Proxy :: Proxy x)])+ (SOP.hpure Proxy :: SOP.NP Proxy xs)+ ]+ SOP.Record _constrName flds ->+ [ FExactObject+ $! H.fromList+ $! SOP.hcfoldMap+ (Proxy :: Proxy FlowTyped)+ (\(SOP.FieldInfo fname :: SOP.FieldInfo x) ->+ [ ( T.pack (fieldLabelModifier opts fname)+ , callType (Proxy :: Proxy x)+ )+ ]+ )+ flds+ ]+ SOP.Infix{} ->+ error "aeson-flowtyped: Unsupported use of infix constructor"+ singleEncode _ =+ error "aeson-flowtyped: Errorneous detection of single constructor"++ sumNullaryEncode constrsNP+ | allNullaryToStringTag opts+ = [ FLiteral (A.String (T.pack (constructorTagModifier opts tag)))+ | tag <- SOP.hcfoldMap (Proxy :: Proxy SOP.Top)+ (\(SOP.Constructor constrName) -> [constrName])+ constrsNP+ ]+ | otherwise+ = [ nullarySumObject (T.pack (constructorTagModifier opts tag))+ | tag <- SOP.hcfoldMap (Proxy :: Proxy SOP.Top)+ (\(SOP.Constructor constrName) -> [constrName])+ constrsNP+ ]++ nullarySumObject tagValue = case sumEncoding opts of+ TaggedObject (T.pack -> tagFld) _contentsFld ->+ FExactObject (H.singleton tagFld (FLiteral (A.String tagValue)))+ UntaggedValue -> FTuple V.empty+ ObjectWithSingleField ->+ FExactObject (H.singleton tagValue (FTuple V.empty))+ TwoElemArray ->+ FTuple (V.fromListN 2 [FLiteral (A.String tagValue), FTuple V.empty])++ renderConstrTag = FLiteral . A.String . T.pack . constructorTagModifier opts++ moduleComment s = T.concat ["Origin module: `", T.pack s, "`"]+ typeComment s = T.concat ["Origin type: ", T.pack s]+ constrComment s = T.concat ["Origin constructor: ", T.pack s]++ isNullary :: forall xs . SOP.SListI xs => Bool+ isNullary = SOP.lengthSList (Proxy :: Proxy xs) == 0+++data ConstructorsKind+ = SumRecords+ | SumConstructors+ | SumNullaryConstructors+ | SingleRecord+ | SingleConstructor+ | SingleNullaryConstructor+ | Unsupported++-- | '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++--------------------------------------------------------------------------------+-- Instances++instance (FlowTyped a) => FlowTyped [a] where+ flowType _ = FArray (callType (Proxy :: Proxy a))+ isPrim _ = True+ flowTypeName _ = Nothing++instance (FlowTyped a) => FlowTyped (Vector a) where+ flowType _ = FArray (callType (Proxy :: Proxy a))+ isPrim _ = True+ flowTypeName _ = Nothing++instance (FlowTyped a) => FlowTyped (VU.Vector a) where+ flowType _ = FArray (callType (Proxy :: Proxy a))+ isPrim _ = True+ flowTypeName _ = Nothing++instance (FlowTyped a) => FlowTyped (VS.Vector a) where+ flowType _ = FArray (callType (Proxy :: Proxy a))+ isPrim _ = True+ flowTypeName _ = Nothing++instance ( FlowTyped a+ , FlowTyped 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 (FlowTyped a) => FlowTyped (Maybe a) where+ flowType _ = FNullable (callType (Proxy :: Proxy a))+ isPrim _ = True+ flowTypeName _ = Nothing++instance ( FlowTyped a+ , FlowTyped 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 ( FlowTyped a+ , FlowTyped b+ , FlowTyped 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 ( FlowTyped a+ , FlowTyped b+ , FlowTyped c+ , FlowTyped 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 ( FlowTyped a+ , FlowTyped b+ , FlowTyped c+ , FlowTyped d+ , FlowTyped 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 :: k), Typeable k) => FlowTyped (Fixed a) where+ isPrim _ = False+ flowType _ = FPrimNumber+ flowTypeName _ = Nothing++instance ( FlowTyped k+ , FlowTyped 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 (FlowTyped 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 (FlowTyped a) => FlowTyped (I.IntMap a) where+ isPrim _ = False+ flowType _ =+ Fix+ . Array+ . Fix+ . Tuple+ . V.fromListN 2+ $ [FPrimNumber, callType (Proxy :: Proxy a)]+ flowTypeName _ = Nothing++instance (FlowTyped 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 (FlowTyped 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