diff --git a/aeson-flowtyped.cabal b/aeson-flowtyped.cabal --- a/aeson-flowtyped.cabal +++ b/aeson-flowtyped.cabal @@ -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 diff --git a/src/Data/Aeson/Flow.hs b/src/Data/Aeson/Flow.hs --- a/src/Data/Aeson/Flow.hs +++ b/src/Data/Aeson/Flow.hs @@ -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 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 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 =\n\ - \ [A,Tree[]];\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,Tree[]];" + , "" + ] + @=? generateModule flowModuleOptions [export @(Tree ())] + , testCase "polymorphism (arity 2)" + $ "// @flow\n\ \// This module has been generated by aeson-flowtyped.\n\n\ \export type Poly2 =\n\ \ {| tag: 'Poly2', contents: [A,B] |} |\n\ - \ {| tag: 'Poly2Go', contents: Poly2 |};\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 |};\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 [])