aeson-flowtyped 0.12.2 → 0.13.2.1
raw patch · 3 files changed
+1322/−1252 lines, 3 filesdep +generics-sopdep ~base
Dependencies added: generics-sop
Dependency ranges changed: base
Files
- aeson-flowtyped.cabal +4/−3
- src/Data/Aeson/Flow.hs +1211/−1132
- test/Spec.hs +107/−117
aeson-flowtyped.cabal view
@@ -1,5 +1,5 @@ name: aeson-flowtyped-version: 0.12.2+version: 0.13.2.1 synopsis: Create Flow or TypeScript type definitions from Haskell data types. description: Create Flow or TypeScript type definitions from Haskell data types. category: Web@@ -14,18 +14,19 @@ source-repository head type: git- location: https://github.com/mikeplus64/aeson-flowtyped+ location: https://gitlab.com/transportengineering/aeson-flowtyped library hs-source-dirs: src build-depends: aeson >=0.8- , base >= 4.11 && < 4.16+ , base >= 4.11 && < 4.17 , containers , data-fix , deriving-compat , free+ , generics-sop , recursion-schemes , reflection , scientific
src/Data/Aeson/Flow.hs view
@@ -1,1134 +1,1213 @@-{-# 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|]- ])+{-# 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|]+ ]+ ) deriveEq1 ''FlowTypeF
test/Spec.hs view
@@ -1,40 +1,42 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-import Data.Aeson (Value)-import Data.Aeson.Flow as Flow-import Data.Fix (Fix (..))+{-# LANGUAGE TypeApplications #-}+import Data.Aeson ( Value )+import Data.Aeson.Flow as Flow+import Data.Fix ( Fix(..) ) import Data.Functor.Foldable-import Data.HashMap.Strict (HashMap)-import Data.Proxy (Proxy (..))-import Data.Text (Text)-import Data.Tree (Tree)-import Data.Vector (Vector)+import Data.HashMap.Strict ( HashMap )+import Data.Maybe+import Data.Proxy ( Proxy(..) )+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Tree ( Tree )+import Data.Vector ( Vector ) import GHC.Generics import Test.Tasty import Test.Tasty.HUnit --- | Pretty-print a flowtype in flowtype syntax-exportFlowTypeAs :: Text -> FlowType -> Text-exportFlowTypeAs = exportTypeAs RenderOptions{renderMode=RenderFlow}- data User = User- { username :: Text- , realname :: Maybe Text- , dob :: Maybe (Int, Int, Int)+ { username :: Text+ , realname :: Maybe Text+ , dob :: Maybe (Int, Int, Int) , extraInfo :: Value- } deriving (Generic)+ }+ deriving Generic instance FlowTyped User data Recur = Recur- { asdf :: Int- , stuff :: [User]+ { asdf :: Int+ , stuff :: [User] , recurs :: [Recur]- } deriving (Generic)+ }+ deriving Generic instance FlowTyped Recur @@ -47,138 +49,104 @@ data Adt4 = A4 | B4 | C4 | D4 deriving (Generic) instance FlowTyped Adt4 -data Sub = Sub Adt4 deriving (Generic)+data Sub = Sub Adt4+ deriving Generic instance FlowTyped Sub data Codep = Codep { corecurs :: [Recur]- , cousers :: [User]- , subsub :: Sub- } deriving (Generic)+ , cousers :: [User]+ , subsub :: Sub+ }+ deriving Generic instance FlowTyped Codep data Hmap = Hmap (HashMap Text User)- deriving (Generic)+ deriving Generic instance FlowTyped Hmap data Poly2 a b = Poly2 a b | Poly2Go (Poly2 a b) deriving (Generic) -instance (Typeable a, FlowTyped a, Typeable b, FlowTyped b) =>- FlowTyped (Poly2 a b) where- flowTypeVars _ =- [ typeRep (Var :: Var a)- , typeRep (Var :: Var b)- ]+instance (FlowTyped a, FlowTyped b) => FlowTyped (Poly2 a b) where+ flowTypeVars _ = [Flowable (Proxy :: Proxy a), Flowable (Proxy :: Proxy b)] data Mono = Mono (Poly2 Int Bool) (Poly2 Bool Int)- deriving (Generic)+ deriving Generic instance FlowTyped Mono main :: IO ()-main = defaultMain $ testGroup "aeson-flowtyped"- [ testCase "nullable" $- showFlowType (flowType (Proxy :: Proxy (Maybe Int))) @=?- showFlowType (FNullable FPrimNumber)-+main = defaultMain $ testGroup+ "aeson-flowtyped"+ [ testCase "nullable" $ testShowFlow @(Maybe Int) @=? testShowRawFlow+ (FNullable FPrimNumber) , testCase "array" $ do- showFlowType (flowType (Proxy :: Proxy [Int])) @=?- showFlowType (FArray FPrimNumber)-- showFlowType (flowType (Proxy :: Proxy (Vector Int))) @=?- showFlowType (FArray FPrimNumber) -- (Fix (Array (Fix (Prim Number))))+ testShowFlow @[Int] @=? testShowRawFlow (FArray FPrimNumber)+ testShowFlow @(Vector Int) @=? testShowRawFlow (FArray FPrimNumber) -- XXX: actually use Eq-- , testCase "User export" $- "export type User =\n\+ , testCase "User export"+ $ trimSpaces+ "export type User =\n\ \ {| extraInfo: mixed,\n\ \ dob: null | [number,number,number],\n\ \ username: string,\n\- \ realname: null | string |};" @=?- exportFlowTypeAs "User" (flowType (Proxy :: Proxy User))-- , testCase "Recursive type export" $- "export type Recur =\n\- \ {| stuff: User[], recurs: Recur[], asdf: number |};" @=?- exportFlowTypeAs "Recur" (flowType (Proxy :: Proxy Recur))-- , testCase "Nullary string tags (2 tags)" $- "export type Adt2 =\n\- \ 'A2' |\n\- \ 'B2';" @=?- exportFlowTypeAs "Adt2" (flowType (Proxy :: Proxy Adt2))-- , testCase "Nullary string tags (3 tags)" $- "export type Adt3 =\n\- \ 'A3' |\n\- \ 'B3' |\n\- \ 'C3';" @=?- exportFlowTypeAs "Adt3" (flowType (Proxy :: Proxy Adt3))-- , testCase "Nullary string tags (4 tags)" $- "export type Adt4 =\n\- \ 'A4' |\n\- \ 'B4' |\n\- \ 'C4' |\n\- \ 'D4';" @=?- exportFlowTypeAs "Adt4" (flowType (Proxy :: Proxy Adt4))-- , testCase "map-style object / hashmap instance" $- "export type Hmap =\n\- \ { [key: string]: User };" @=?- exportFlowTypeAs "Hmap" (flowType (Proxy :: Proxy (HashMap Text User)))-- , testCase "parens around nullable array" $- "export type T =\n\- \ null | string[];" @=?- exportFlowTypeAs "T" (flowType (Proxy :: Proxy (Maybe [Text])))-- , testCase "parens around nullable array of nullable elements" $- "export type T =\n\- \ null | (null | string)[];" @=?- exportFlowTypeAs "T" (flowType (Proxy :: Proxy (Maybe [Maybe Text])))-- , testCase "export dependencies" $- [ FlowName (Proxy :: Proxy Codep) "Codep"+ \ realname: null | string |};"+ @=? exportFlowType @User+ , testCase "Recursive type export"+ $ trimSpaces+ "export type Recur = {| stuff: User[], recurs: Recur[], asdf: number |};"+ @=? exportFlowType @Recur+ , testCase "Nullary string tags (2 tags)"+ $ "export type Adt2 = 'A2' | 'B2';"+ @=? exportFlowType @Adt2+ , testCase "Nullary string tags (3 tags)"+ $ "export type Adt3 = 'A3' | 'B3' | 'C3';"+ @=? exportFlowType @Adt3+ , testCase "Nullary string tags (4 tags)"+ $ "export type Adt4 = 'A4' | 'B4' | 'C4' | 'D4';"+ @=? exportFlowType @Adt4+ , testCase "map-style object / hashmap instance"+ $ "export type Hmap = { [key: string]: User };"+ @=? exportFlowTypeAs @(HashMap Text User) "Hmap"+ , testCase "parens around nullable array"+ $ "export type T = null | string[];"+ @=? exportFlowTypeAs @(Maybe [Text]) "T"+ , testCase "parens around nullable array of nullable elements"+ $ "export type T = null | (null | string)[];"+ @=? exportFlowTypeAs @(Maybe [Maybe Text]) "T"+ , testCase "export dependencies"+ $ [ FlowName (Proxy :: Proxy Codep) "Codep" , FlowName (Proxy :: Proxy User) "User" , FlowName (Proxy :: Proxy Recur) "Recur" , FlowName (Proxy :: Proxy Sub) "Sub" , FlowName (Proxy :: Proxy Adt4) "Adt4"- ] @=?- exportsDependencies- [ Export (Proxy :: Proxy Codep) ]-- , testCase "polymorphism (arity 1)" $- "// @flow\n\- \// This module has been generated by aeson-flowtyped.\n\n\- \export type Tree<A> =\n\- \ [A,Tree<A>[]];\n" @=?- generateModule flowModuleOptions- [ Export (Proxy :: Proxy (Tree (Var 0)))- ]-- {-- , testCase "polymorphism (arity 2)" $- "// @flow\n\+ @=? exportsDependencies [export @Codep]+ , testCase "polymorphism (arity 1)"+ $ T.unlines+ [ "// @flow"+ , "// This module has been generated by aeson-flowtyped."+ , ""+ , "export type Tree<A> = [A,Tree<A>[]];"+ , ""+ ]+ @=? generateModule flowModuleOptions [export @(Tree ())]+ , testCase "polymorphism (arity 2)"+ $ "// @flow\n\ \// This module has been generated by aeson-flowtyped.\n\n\ \export type Poly2<A, B> =\n\ \ {| tag: 'Poly2', contents: [A,B] |} |\n\- \ {| tag: 'Poly2Go', contents: Poly2<A, B> |};\n" @=?- generateModule flowModuleOptions- [ Export (Proxy :: Proxy (Poly2 (Var 0) (Var 1)))- ]- -}-- , testCase "monomorphic use of polymorphic type (dependencies)" $- [ FlowName (Proxy :: Proxy Mono) "Mono"+ \ {| tag: 'Poly2Go', contents: Poly2<A, B> |};\n"+ @=? generateModule flowModuleOptions [export @(Poly2 () ())]+ , testCase "monomorphic use of polymorphic type (dependencies)"+ $ [ FlowName (Proxy :: Proxy Mono) "Mono" , FlowName (Proxy :: Proxy (Poly2 () ())) "Poly2"- ] @=?- exportsDependencies [Export (Proxy :: Proxy Mono)]+ ]+ @=? exportsDependencies [export @Mono] {- , testCase "monomorphic use of polymorphic type" $@@ -190,5 +158,27 @@ generateModule flowModuleOptions [Export (Proxy :: Proxy Mono)] -}- ]++-- | Pretty-print a flowtype in flowtype syntax+exportFlowType :: forall a . (FlowTyped a) => Text+exportFlowType =+ exportFlowTypeAs @a (fromJust (flowTypeName (Proxy :: Proxy a)))++-- | Pretty-print a flowtype in flowtype syntax+exportFlowTypeAs :: forall a . (FlowTyped a) => Text -> Text+exportFlowTypeAs name = trimSpaces+ (exportTypeAs RenderOptions { renderMode = RenderFlow }+ name+ (flowType (Proxy :: Proxy a))+ []+ )++trimSpaces :: Text -> Text+trimSpaces = T.unwords . T.words . T.filter (\a -> a /= '\n')++testShowFlow :: forall a . FlowTyped a => Text+testShowFlow = trimSpaces (showFlowType (flowType (Proxy :: Proxy a)) [])++testShowRawFlow :: FlowType -> Text+testShowRawFlow t = trimSpaces (showFlowType t [])