diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/aeson-flowtyped.cabal b/aeson-flowtyped.cabal --- a/aeson-flowtyped.cabal +++ b/aeson-flowtyped.cabal @@ -1,10 +1,10 @@ name: aeson-flowtyped -version: 0.13.2.1 +version: 0.14.0 synopsis: Create Flow or TypeScript type definitions from Haskell data types. description: Create Flow or TypeScript type definitions from Haskell data types. category: Web -homepage: https://github.com/mikeplus64/aeson-flowtyped#readme -bug-reports: https://github.com/mikeplus64/aeson-flowtyped/issues +homepage: https://gitlab.com/transportengineering/aeson-flowtyped#readme +bug-reports: https://gitlab.com/transportengineering/aeson-flowtyped/issues author: Mike Ledger maintainer: mike@quasimal.com license: BSD3 @@ -20,8 +20,8 @@ hs-source-dirs: src build-depends: - aeson >=0.8 - , base >= 4.11 && < 4.17 + base >=4.11 && <4.18 + , aeson >=2.0 , containers , data-fix , deriving-compat @@ -50,9 +50,9 @@ hs-source-dirs: test build-depends: - aeson >=0.8 + base + , aeson >=2.0 , aeson-flowtyped - , base , containers , data-fix , recursion-schemes 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,1213 +1,1153 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | Derive using aeson 'Options'. --- --- Does not currently support the 'unwrapUnaryRecords' option. -module Data.Aeson.Flow - ( -- * AST types - FlowTyped (..), - callType, - FlowTypeF, - FlowType, - -- , Fix (..) - pattern FObject, - pattern FExactObject, - pattern FObjectMap, - pattern FArray, - pattern FTuple, - pattern FLabelledTuple, - pattern FFun, - pattern FAlt, - pattern FPrim, - pattern FPrimBoolean, - pattern FPrimNumber, - pattern FPrimString, - pattern FPrimBottom, - pattern FPrimMixed, - pattern FPrimUnknown, - pattern FPrimNull, - pattern FPrimNever, - pattern FPrimUndefined, - pattern FPrimAny, - pattern FNullable, - pattern FOmitable, - pattern FLiteral, - pattern FTag, - pattern FName, - pattern FGenericParam, - pattern FCallType, - - -- * Code generation - - -- ** Wholesale ES6/flow/typescript modules - Export, - export, - RenderMode (..), - RenderOptions (..), - ModuleOptions (..), - typeScriptModuleOptions, - flowModuleOptions, - generateModule, - writeModule, - showTypeAs, - exportTypeAs, - - -- ** Convenience for generating flowtypes from other types - FlowTyFields (..), - FlowDeconstructField, - - -- ** TS specific - showTypeScriptType, - - -- ** Flow specific - showFlowType, - - -- * Dependencies - exportsDependencies, - dependencies, - - -- * Utility - FlowName (..), - Flowable (..), - defaultFlowTypeName, - defaultFlowType, - ) -where - -import Control.Monad.Reader -import Control.Monad.State.Strict -import qualified Data.Aeson as A -import Data.Aeson.Types - ( Options (..), - SumEncoding (..), - ) -import Data.Eq.Deriving (deriveEq1) -import Data.Fix (Fix (..)) -import Data.Fixed (Fixed) -import Data.Functor.Classes -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as H -import qualified Data.HashSet as HashSet -import Data.Int -import qualified Data.IntMap.Strict as I -import qualified Data.IntSet as IntSet -import qualified Data.Map.Strict as M -import Data.Maybe -import qualified Data.Monoid as Monoid -import Data.Proxy -import Data.Reflection -import Data.Scientific (Scientific) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import qualified Data.Text.Lazy as TL -import Data.Time (UTCTime) -import qualified Data.Tree as Tree -import Data.Typeable -import Data.Vector (Vector) -import qualified Data.Vector as V -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Unboxed as VU -import qualified Data.Void as Void -import Data.Word -import GHC.Generics - ( D1, - Generic, - Meta (..), - Rep, - from, - ) -import GHC.TypeLits -import qualified Generics.SOP as SOP -import qualified Generics.SOP.GGP as SOP -import qualified Text.PrettyPrint.Leijen as PP - --- | The main AST for flowtypes. -data FlowTypeF a - = Object !(HashMap Text a) - | ExactObject !(HashMap Text a) - | ObjectMap !Text a a - | Array a - | Tuple !(Vector a) - | LabelledTuple !(Vector (Maybe Text, a)) - | Fun !(Vector (Text, a)) a - | Alt a a - | Prim !PrimType - | Nullable a - | -- | omitable when null or undefined - Omitable a - | Literal !A.Value - | Tag !Text - | GenericParam !Int - | CallType !FlowName [a] - | SomeFlowType !Flowable - | TypeDoc !(Vector Text) a - deriving (Show, Eq, Functor, Traversable, Foldable) - --- | A primitive flow/javascript type -data PrimType - = Boolean - | Number - | String - | Null - | Undefined - | -- | uninhabited type; @never@ in typescript, and @empty@ in flow - Bottom - | -- | @unknown@ in typescript, @mixed@ in flow - Mixed - | Any - deriving (Show, Read, Eq, Ord) - --- | A name for a flowtyped data-type. These are returned by 'dependencies'. -data FlowName where - FlowName :: (FlowTyped a) => Proxy a -> Text -> FlowName - -data Flowable where - Flowable :: (FlowTyped a) => Proxy a -> Flowable - -data Showy f a - = forall s. - Reifies s (Int -> a -> ShowS) => - Showy - (f (Inj s a)) - -instance Show1 (Showy FlowTypeF) where - liftShowsPrec _ _ i (Showy a) = showsPrec i a - --------------------------------------------------------------------------------- --- Magical newtype for injecting showsPrec into any arbitrary Show - -inj :: Proxy s -> a -> Inj s a -inj _ = Inj - -newtype Inj s a = Inj a - --- needs UndecidableInstances - -instance Reifies s (Int -> a -> ShowS) => Show (Inj s a) where - showsPrec i (Inj a) = reflect (Proxy :: Proxy s) i a - --------------------------------------------------------------------------------- - -data RenderMode = RenderTypeScript | RenderFlow - deriving (Eq, Show) - -data RenderOptions = RenderOptions - { renderMode :: !RenderMode - } - deriving (Eq, Show) - -instance Show FlowName where - show (FlowName _ t) = show t - -instance Eq FlowName where - FlowName _t0 n0 == FlowName _t1 n1 = n0 == n1 - --- case eqT :: Maybe (t0 :~: t1) of --- Just Refl -> (t0, n0) == (t1, n1) --- Nothing -> False - -instance Ord FlowName where - FlowName _t0 n0 `compare` FlowName _t1 n1 = n0 `compare` n1 - --- XXX this breaks using (typeRep t0, n0) `compare` (typeRep t1, n1) for some --- reason... dunno why - -instance Show Flowable where - show (Flowable t) = show (typeRep t) - -instance Eq Flowable where - Flowable a == Flowable b = typeRep a == typeRep b - -instance Ord Flowable where - Flowable a `compare` Flowable b = typeRep a `compare` typeRep b - --- XXX: vector >= 0.12 has Eq1 vector which allows us to use eq for Fix --- FlowTypeF and related types - --------------------------------------------------------------------------------- - -pattern FObject :: HashMap Text FlowType -> FlowType -pattern FObject x = Fix (Object x) - -pattern FExactObject :: HashMap Text FlowType -> FlowType -pattern FExactObject x = Fix (ExactObject x) - -pattern FObjectMap :: Text -> FlowType -> FlowType -> FlowType -pattern FObjectMap keyName keyType vals = Fix (ObjectMap keyName keyType vals) - -pattern FArray :: FlowType -> FlowType -pattern FArray a = Fix (Array a) - -pattern FTuple :: Vector FlowType -> FlowType -pattern FTuple a = Fix (Tuple a) - -pattern FLabelledTuple :: Vector (Maybe Text, FlowType) -> FlowType -pattern FLabelledTuple a = Fix (LabelledTuple a) - -pattern FFun :: Vector (Text, FlowType) -> FlowType -> FlowType -pattern FFun v t = Fix (Fun v t) - -pattern FAlt :: FlowType -> FlowType -> FlowType -pattern FAlt a b = Fix (Alt a b) - -pattern FPrim :: PrimType -> FlowType -pattern FPrim a = Fix (Prim a) - -pattern FPrimBoolean :: FlowType -pattern FPrimBoolean = FPrim Boolean - -pattern FPrimNumber :: FlowType -pattern FPrimNumber = FPrim Number - -pattern FPrimString :: FlowType -pattern FPrimString = FPrim String - -pattern FPrimBottom :: FlowType -pattern FPrimBottom = FPrim Bottom - -pattern FPrimMixed :: FlowType -pattern FPrimMixed = FPrim Mixed - -pattern FPrimUnknown :: FlowType -pattern FPrimUnknown = FPrim Mixed - -pattern FPrimAny :: FlowType -pattern FPrimAny = FPrim Any - -pattern FPrimNever :: FlowType -pattern FPrimNever = FPrim Bottom - -pattern FPrimNull :: FlowType -pattern FPrimNull = FPrim Null - -pattern FPrimUndefined :: FlowType -pattern FPrimUndefined = FPrim Undefined - -pattern FNullable :: FlowType -> FlowType -pattern FNullable a = Fix (Nullable a) - -pattern FOmitable :: FlowType -> FlowType -pattern FOmitable a = Fix (Omitable a) - -pattern FLiteral :: A.Value -> FlowType -pattern FLiteral a = Fix (Literal a) - -pattern FTag :: Text -> FlowType -pattern FTag a = Fix (Tag a) - -pattern FName :: FlowName -> FlowType -pattern FName a = Fix (CallType a []) - -pattern FGenericParam :: Int -> FlowType -pattern FGenericParam a = Fix (GenericParam a) - -pattern FCallType :: FlowName -> [FlowType] -> FlowType -pattern FCallType f xs = Fix (CallType f xs) - -pattern FTypeDoc :: Vector Text -> FlowType -> FlowType -pattern FTypeDoc f xs = Fix (TypeDoc f xs) - --------------------------------------------------------------------------------- - -instance Show1 FlowTypeF where - liftShowsPrec sp sl i a = - liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a))) - -type FlowType = Fix FlowTypeF - -text :: Text -> PP.Doc -text = PP.text . T.unpack - -squotes :: Text -> PP.Doc -squotes = PP.squotes . text . T.replace "'" "\\'" - -type Poly = ReaderT RenderOptions (Reader [Flowable]) - -ppAlts :: [FlowType] -> FlowType -> Poly PP.Doc -ppAlts alts (Fix f) = case f of - Alt a b -> ppAlts (a : alts) b - x -> PP.align . sep <$> mapM pp (reverse (Fix x : alts)) - where - sep [x] = x - sep (x : xs) = x PP.<+> PP.string "|" PP.<$> sep xs - sep _ = PP.empty - -braceList :: [PP.Doc] -> PP.Doc -braceList = - (\s -> PP.lbrace PP. s PP. PP.rbrace) - . PP.align - . PP.sep - . PP.punctuate PP.comma - -braceBarList :: [PP.Doc] -> PP.Doc -braceBarList = - (\s -> PP.text "{|" PP. s PP. PP.text "|}") - . PP.align - . PP.sep - . PP.punctuate PP.comma - -ppJson :: A.Value -> PP.Doc -ppJson v = case v of - A.Array a -> PP.list (map ppJson (V.toList a)) - A.String t -> squotes t - A.Number n -> PP.string (show n) - A.Bool t -> if t then PP.string "true" else PP.string "false" - A.Null -> PP.string "null" - A.Object obj -> - braceBarList - ( map - ( \(name, fty) -> - PP.space - PP.<> text name - PP.<+> PP.colon - PP.<+> ppJson fty - PP.<> PP.space - ) - (H.toList obj) - ) - -mayWrap :: FlowType -> PP.Doc -> PP.Doc -mayWrap (Fix f) x = case f of - Nullable _ -> PP.parens x - Omitable _ -> PP.parens x - Alt _ _ -> PP.parens x - Array _ -> PP.parens x - _ -> x - -ppObject :: HashMap Text FlowType -> Poly [PP.Doc] -ppObject = mapM ppField . H.toList - where - ppField (name, fty) = do - case fty of - Fix (Omitable fty') -> - -- key?: type - (\fty'' -> text name PP.<> PP.text "?" PP.<> PP.colon PP.<+> fty'') - <$> pp fty' - fty' -> - -- key: type - (\fty'' -> text name PP.<> PP.colon PP.<+> fty'') <$> pp fty' - -polyVarNames :: [Text] -polyVarNames = - map T.singleton ['A' .. 'Z'] - ++ zipWith (\i t -> t `T.append` T.pack (show i)) [0 :: Int ..] polyVarNames - -pp :: FlowType -> Poly PP.Doc -pp (Fix ft) = case ft of - ObjectMap keyName keyType a -> do - keyTy <- pp keyType - r <- pp a - pure - ( braceList - [ PP.brackets (text keyName PP.<> PP.text ":" PP.<+> keyTy) - PP.<> PP.colon - PP.<+> r - ] - ) - Object hm -> braceList <$> ppObject hm - ExactObject hm -> do - mode <- asks renderMode - case mode of - RenderFlow -> braceBarList <$> ppObject hm - RenderTypeScript -> braceList <$> ppObject hm - - -- x[] - Array a -> (\r -> mayWrap a r PP.<> PP.string "[]") <$> pp a - -- [x, y, z] - Tuple t -> PP.list <$> mapM pp (V.toList t) - -- [l1: x, y, l2: z] - LabelledTuple t -> - PP.list - <$> mapM - ( \(mlbl, ty) -> case mlbl of - Just lbl -> ((text lbl PP.<> PP.string ":") PP.<+>) <$> pp ty - Nothing -> pp ty - ) - (V.toList t) - Alt a b -> ppAlts [a] b - Prim pt -> do - mode <- asks renderMode - return $ case pt of - Boolean -> PP.text "boolean" - Number -> PP.text "number" - String -> PP.text "string" - Null -> PP.text "null" - Undefined -> PP.text "undefined" - Any -> PP.text "any" - Mixed -> case mode of - RenderFlow -> PP.text "mixed" - RenderTypeScript -> PP.text "unknown" - Bottom -> case mode of - RenderFlow -> PP.text "empty" - RenderTypeScript -> PP.text "never" - Nullable a -> - -- n.b. there is no 'undefined' in json. void is undefined | null in both ts - -- and flow (and ?x syntax for void|x) - (\a' -> PP.text "null" PP.<+> PP.string "|" PP.<+> a') <$> pp a - Omitable a -> pp (FNullable a) - Literal a -> return (ppJson a) - Tag t -> return (squotes t) - GenericParam ix -> return (text (polyVarNames !! ix)) - CallType (FlowName _ t) [] -> return (text t) - CallType (FlowName _ t) args -> do - vs <- mapM pp args - return (text t PP.<> PP.angles (PP.hsep (PP.punctuate PP.comma vs))) - TypeDoc _doc t -> pp t - _ -> return (PP.string (show ft)) - --- | Pretty-print a flowtype in flowtype syntax -renderTypeWithOptions :: RenderOptions -> FlowType -> [Flowable] -> PP.Doc -renderTypeWithOptions opts ft params = - (pp ft `runReaderT` opts) `runReader` params - --- | Pretty-print a flowtype in flowtype syntax -showFlowType :: FlowType -> [Flowable] -> Text -showFlowType ft params = - T.pack . show $ - renderTypeWithOptions - RenderOptions {renderMode = RenderFlow} - ft - params - --- | Pretty-print a flowtype in flowtype syntax -showTypeScriptType :: FlowType -> [Flowable] -> Text -showTypeScriptType ft params = - T.pack . show $ - renderTypeWithOptions - RenderOptions {renderMode = RenderTypeScript} - ft - params - --------------------------------------------------------------------------------- --- Module exporting - --- | Generate a @ export type @ declaration. -exportTypeAs :: RenderOptions -> Text -> FlowType -> [Flowable] -> Text -exportTypeAs opts = showTypeAs opts True - --- | Generate a @ type @ declaration, possibly an export. -showTypeAs :: RenderOptions -> Bool -> Text -> FlowType -> [Flowable] -> Text -showTypeAs opts isExport name ft params = - T.pack - . render - $ PP.string (if isExport then "export type " else "type ") - PP.<> text name - PP.<> renderedParams - PP.<+> text "=" - PP.<+> renderedTypeDecl - PP.<> text ";" - PP.<> PP.linebreak - where - renderedTypeDecl = renderTypeWithOptions opts ft params - renderedParams - | null params = mempty - | otherwise = - PP.angles - ( PP.hsep - (PP.punctuate PP.comma (map text (take (length params) polyVarNames))) - ) - - render = ($ []) . PP.displayS . PP.renderPretty 1.0 80 - --- | Compute all the dependencies of a 'FlowTyped' thing, including itself. -dependencies :: (FlowTyped a) => Proxy a -> Set.Set FlowName -dependencies p0 = - ( case flowTypeName p0 of - Just t -> Set.insert (FlowName p0 t) - Nothing -> id - ) - (M.foldl' Set.union Set.empty (transitiveDeps (Flowable p0) M.empty)) - where - flowNameToFlowable (FlowName fn _) = Flowable fn - - immediateDeps :: FlowType -> Set.Set FlowName - immediateDeps (FCallType n tys) = - Set.insert n (Set.unions (map immediateDeps tys)) - immediateDeps (Fix p) = foldMap immediateDeps p - - transitiveDeps :: - Flowable -> - M.Map Flowable (Set.Set FlowName) -> - M.Map Flowable (Set.Set FlowName) - transitiveDeps fpf@(Flowable p) acc - | fpf `M.notMember` acc = - let imms = immediateDeps (flowType p) - withThis = M.insert fpf imms acc - in Set.foldr' (transitiveDeps . flowNameToFlowable) withThis imms - | otherwise = - acc - -data ModuleOptions = ModuleOptions - { -- | You might want to change this to include e.g. flow-runtime - pragmas :: [Text], - header :: [Text], - exportDeps :: Bool, - computeDeps :: Bool, - renderOptions :: RenderOptions - } - deriving (Eq, Show) - -flowModuleOptions :: ModuleOptions -flowModuleOptions = - ModuleOptions - { pragmas = ["// @flow"], - header = ["This module has been generated by aeson-flowtyped."], - exportDeps = True, - computeDeps = True, - renderOptions = RenderOptions {renderMode = RenderFlow} - } - -typeScriptModuleOptions :: ModuleOptions -typeScriptModuleOptions = - ModuleOptions - { pragmas = [], - header = ["This module has been generated by aeson-flowtyped."], - exportDeps = True, - computeDeps = True, - renderOptions = RenderOptions {renderMode = RenderTypeScript} - } - -data Export where - Export :: FlowTyped a => Proxy a -> Export - -export :: forall a. FlowTyped a => Export -export = Export (Proxy :: Proxy a) - -instance Eq Export where - Export p0 == Export p1 = - flowTypeName p0 == flowTypeName p1 || typeRep p0 == typeRep p1 - -exportsDependencies :: [Export] -> Set.Set FlowName -exportsDependencies = foldMap (\(Export a) -> dependencies a) - -generateModule :: ModuleOptions -> [Export] -> Text -generateModule opts exports = - T.unlines $ - ( \m -> - (pragmas opts ++ map ("// " `T.append`) (header opts)) ++ (T.empty : m) - ) - . map flowDecl - . flowNames - $ exports - where - flowNames = - if computeDeps opts - then Set.toList . exportsDependencies - else mapMaybe (\(Export p) -> FlowName p <$> flowTypeName p) - - flowDecl (FlowName p name) = - if Export p `elem` exports || exportDeps opts - then showTypeAs (renderOptions opts) True name (flowType p) (flowTypeVars p) - else - showTypeAs - (renderOptions opts) - False - name - (flowType p) - (flowTypeVars p) - -writeModule :: ModuleOptions -> FilePath -> [Export] -> IO () -writeModule opts path = TIO.writeFile path . generateModule opts - --------------------------------------------------------------------------------- - -type family FlowDeconstructField (k :: t) :: (Symbol, *) - -type instance FlowDeconstructField '(a, b) = '(a, b) - --- | Useful for declaring flowtypes from type-level key/value sets, like --- --- @ --- FlowTyFields :: FlowTyFields Person '['("name", String), '("email", String)] --- @ -data FlowTyFields :: * -> [k] -> * where - FlowTyFields :: FlowTyFields k fs - -class ReifyFlowTyFields a where - reifyFlowTyFields :: Proxy a -> HashMap Text FlowType -> HashMap Text FlowType - -instance ReifyFlowTyFields '[] where - reifyFlowTyFields _ = id - -instance - ( FlowDeconstructField x ~ '(k, v), - KnownSymbol k, - FlowTyped v, - ReifyFlowTyFields xs - ) => - ReifyFlowTyFields (x : xs) - where - reifyFlowTyFields _ acc = - reifyFlowTyFields (Proxy :: Proxy xs) - $! H.insert - (T.pack (symbolVal (Proxy :: Proxy k))) - (flowType (Proxy :: Proxy v)) - acc - -instance (FlowTyped a, ReifyFlowTyFields (fs :: [k]), Typeable fs, Typeable k) => FlowTyped (FlowTyFields a fs) where - flowType _ = FExactObject (reifyFlowTyFields (Proxy :: Proxy fs) H.empty) - flowTypeName _ = flowTypeName (Proxy :: Proxy a) - --------------------------------------------------------------------------------- - -callType' :: (FlowTyped a) => Proxy a -> [FlowType] -> FlowType -callType' p args = case flowTypeName p of - Just n -> FCallType (FlowName p n) args - Nothing -> flowType p - -callType :: forall a. FlowTyped a => Proxy a -> FlowType -callType p = callType' p (map (\(Flowable t) -> callType t) (flowTypeVars p)) - -class Typeable a => FlowTyped a where - flowType :: Proxy a -> FlowType - flowTypeName :: Proxy a -> Maybe Text - - flowTypeVars :: Proxy a -> [Flowable] - flowTypeVars _ = [] - - flowOptions :: Proxy a -> Options - flowOptions _ = A.defaultOptions - - isPrim :: Proxy a -> Bool - isPrim _ = False - - default flowType :: - (SOP.GDatatypeInfo a, SOP.All2 FlowTyped (SOP.GCode a)) => - Proxy a -> - FlowType - flowType p = flowTypeFromSOP (flowOptions p) (SOP.gdatatypeInfo p) - - default flowTypeName :: - (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name) => - Proxy a -> - Maybe Text - flowTypeName = defaultFlowTypeName - --- | 'flowType' using 'SOP.HasDatatypeInfo' -defaultFlowType :: - (SOP.HasDatatypeInfo a, SOP.All2 FlowTyped (SOP.Code a)) => - Options -> - Proxy a -> - FlowType -defaultFlowType opts p = flowTypeFromSOP opts (SOP.datatypeInfo p) - -flowTypeFromSOP :: - SOP.All2 FlowTyped ty => Options -> SOP.DatatypeInfo ty -> FlowType -flowTypeFromSOP opts di = case comments of - [] -> ft - _ -> FTypeDoc (V.fromList comments) ft - where - (ft, comments) = - ( case di of - SOP.ADT moduleName typeName constrInfos _strictness -> do - modify' (moduleComment moduleName :) - modify' (typeComment typeName :) - pure . foldr1 FAlt $! case constrsKind constrInfos 0 0 0 True of - SumRecords -> sumEncode constrInfos - SumConstructors -> sumEncode constrInfos - SumNullaryConstructors -> sumNullaryEncode constrInfos - SingleRecord -> singleEncode constrInfos - SingleConstructor -> singleEncode constrInfos - SingleNullaryConstructor -> [FTuple V.empty] - Unsupported -> - error $ "aeson-flowtyped: Unsupported type " ++ show typeName - SOP.Newtype moduleName typeName constrInfo -> do - modify' (moduleComment moduleName :) - modify' (typeComment typeName :) - case constrInfo of - (SOP.Constructor constrName :: SOP.ConstructorInfo '[x]) -> do - modify' (constrComment constrName :) - pure (callType (Proxy :: Proxy x)) - SOP.Record constrName ((SOP.FieldInfo _fname :: SOP.FieldInfo x) SOP.:* SOP.Nil) -> - do - modify' (constrComment constrName :) - pure (callType (Proxy :: Proxy x)) - ) - `runState` [] - - constrsKind :: - SOP.NP SOP.ConstructorInfo ty -> - -- | total number of record or plain constructors - Int -> - -- | number of record constructors - Int -> - -- | number of plain constructors - Int -> - -- | whether every constructor is nullary - Bool -> - ConstructorsKind - constrsKind SOP.Nil !total !recs !plains !allNullary - | recs == 1 && plains == 0 = SingleRecord - | plains == 1 && recs == 0 = - if allNullary - then SingleNullaryConstructor - else SingleConstructor - | recs == total && plains == 0 = SumRecords - | plains == total && recs == 0 = - if allNullary - then SumNullaryConstructors - else SumConstructors - | otherwise = Unsupported - constrsKind (constr SOP.:* rest) total recs plains allNullary = - case constr of - (SOP.Constructor {} :: SOP.ConstructorInfo flds) -> - constrsKind - rest - (total + 1) - recs - (plains + 1) - (allNullary && isNullary @flds) - (SOP.Record {} :: SOP.ConstructorInfo flds) -> - constrsKind - rest - (total + 1) - (recs + 1) - plains - (allNullary && isNullary @flds) - _ -> Unsupported - - sumEncode, - singleEncode, - sumNullaryEncode :: - SOP.All2 FlowTyped ty => SOP.NP SOP.ConstructorInfo ty -> [FlowType] - sumEncode constrsNP = - SOP.hcfoldMap - (Proxy :: Proxy (SOP.All FlowTyped)) - ( \case - (SOP.Constructor constrName :: SOP.ConstructorInfo xs) -> - let value = - let tuple = - V.fromList - $! SOP.hcfoldMap - (Proxy :: Proxy FlowTyped) - (\(Proxy :: SOP.Proxy x) -> [callType (Proxy :: Proxy x)]) - (SOP.hpure Proxy :: SOP.NP Proxy xs) - in case V.length tuple of - 1 -> V.head tuple - _ -> FTuple tuple - - hasContents = - Monoid.getAny - $! SOP.hcfoldMap - (Proxy :: Proxy SOP.Top) - (\_ -> Monoid.Any True) - (SOP.hpure Proxy :: SOP.NP Proxy xs) - in case sumEncoding opts of - TaggedObject (T.pack -> tagFld) contentsFld - | hasContents -> - [ FExactObject - ( H.fromList - [ (tagFld, renderConstrTag constrName), - (T.pack contentsFld, value) - ] - ) - ] - | otherwise -> - [ FExactObject - (H.singleton tagFld (renderConstrTag constrName)) - ] - UntaggedValue -> [value] - ObjectWithSingleField -> - [ FExactObject - ( H.fromList - [(T.pack (constructorTagModifier opts constrName), value)] - ) - ] - TwoElemArray -> - [FTuple (V.fromListN 2 [renderConstrTag constrName, value])] - SOP.Record constrName flds -> - let fldsList :: H.HashMap Text FlowType - fldsList = - H.fromList - $! SOP.hcfoldMap - (Proxy :: Proxy FlowTyped) - ( \(SOP.FieldInfo fname :: SOP.FieldInfo x) -> - [ ( T.pack (fieldLabelModifier opts fname), - callType (Proxy :: Proxy x) - ) - ] - ) - flds - in case sumEncoding opts of - -- The contents field is not used here but the tag one is - TaggedObject (T.pack -> tagFld) _contentsFld -> - [ FExactObject - (H.insert tagFld (renderConstrTag constrName) fldsList) - ] - UntaggedValue -> [FExactObject fldsList] - ObjectWithSingleField -> - [ FExactObject - ( H.singleton - (T.pack (constructorTagModifier opts constrName)) - (FExactObject fldsList) - ) - ] - TwoElemArray -> - [ FTuple - ( V.fromListN - 2 - [renderConstrTag constrName, FExactObject fldsList] - ) - ] - SOP.Infix {} -> - error "aeson-flowtyped: Unsupported use of infix constructor" - ) - constrsNP - - singleEncode (constr SOP.:* SOP.Nil) = case constr of - (SOP.Constructor _constrName :: SOP.ConstructorInfo xs) -> - [ FTuple . V.fromList - $! SOP.hcfoldMap - (Proxy :: Proxy FlowTyped) - (\(Proxy :: SOP.Proxy x) -> [callType (Proxy :: Proxy x)]) - (SOP.hpure Proxy :: SOP.NP Proxy xs) - ] - SOP.Record _constrName flds -> - [ FExactObject - $! H.fromList - $! SOP.hcfoldMap - (Proxy :: Proxy FlowTyped) - ( \(SOP.FieldInfo fname :: SOP.FieldInfo x) -> - [ ( T.pack (fieldLabelModifier opts fname), - callType (Proxy :: Proxy x) - ) - ] - ) - flds - ] - SOP.Infix {} -> - error "aeson-flowtyped: Unsupported use of infix constructor" - singleEncode _ = - error "aeson-flowtyped: Errorneous detection of single constructor" - - sumNullaryEncode constrsNP - | allNullaryToStringTag opts = - [ FLiteral (A.String (T.pack (constructorTagModifier opts tag))) - | tag <- - SOP.hcfoldMap - (Proxy :: Proxy SOP.Top) - (\(SOP.Constructor constrName) -> [constrName]) - constrsNP - ] - | otherwise = - [ nullarySumObject (T.pack (constructorTagModifier opts tag)) - | tag <- - SOP.hcfoldMap - (Proxy :: Proxy SOP.Top) - (\(SOP.Constructor constrName) -> [constrName]) - constrsNP - ] - - nullarySumObject tagValue = case sumEncoding opts of - TaggedObject (T.pack -> tagFld) _contentsFld -> - FExactObject (H.singleton tagFld (FLiteral (A.String tagValue))) - UntaggedValue -> FTuple V.empty - ObjectWithSingleField -> - FExactObject (H.singleton tagValue (FTuple V.empty)) - TwoElemArray -> - FTuple (V.fromListN 2 [FLiteral (A.String tagValue), FTuple V.empty]) - - renderConstrTag = FLiteral . A.String . T.pack . constructorTagModifier opts - - moduleComment s = T.concat ["Origin module: `", T.pack s, "`"] - typeComment s = T.concat ["Origin type: ", T.pack s] - constrComment s = T.concat ["Origin constructor: ", T.pack s] - - isNullary :: forall xs. SOP.SListI xs => Bool - isNullary = SOP.lengthSList (Proxy :: Proxy xs) == 0 - -data ConstructorsKind - = SumRecords - | SumConstructors - | SumNullaryConstructors - | SingleRecord - | SingleConstructor - | SingleNullaryConstructor - | Unsupported - --- | 'flowTypeName' using 'Generic' -defaultFlowTypeName :: - (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name) => - Proxy a -> - Maybe Text -defaultFlowTypeName = - Just . cleanup . T.pack . symbolVal . pGetName . fmap from - where - pGetName :: Proxy (D1 ('MetaData name mod pkg t) c x) -> Proxy name - pGetName _ = Proxy - cleanup = T.replace "'" "_" -- I think this is the only illegal token in JS - -- that's allowed in Haskell, other than type - -- operators... TODO, rename type operators - --------------------------------------------------------------------------------- --- Instances - -instance (FlowTyped a) => FlowTyped [a] where - flowType _ = FArray (callType (Proxy :: Proxy a)) - isPrim _ = True - flowTypeName _ = Nothing - -instance (FlowTyped a) => FlowTyped (Vector a) where - flowType _ = FArray (callType (Proxy :: Proxy a)) - isPrim _ = True - flowTypeName _ = Nothing - -instance (FlowTyped a) => FlowTyped (VU.Vector a) where - flowType _ = FArray (callType (Proxy :: Proxy a)) - isPrim _ = True - flowTypeName _ = Nothing - -instance (FlowTyped a) => FlowTyped (VS.Vector a) where - flowType _ = FArray (callType (Proxy :: Proxy a)) - isPrim _ = True - flowTypeName _ = Nothing - -instance - ( FlowTyped a, - FlowTyped b - ) => - FlowTyped (a, b) - where - flowTypeName _ = Nothing - flowType _ = FTuple (V.fromList [aFt, bFt]) - where - aFt = callType (Proxy :: Proxy a) - bFt = callType (Proxy :: Proxy b) - -instance (FlowTyped a) => FlowTyped (Maybe a) where - flowType _ = FNullable (callType (Proxy :: Proxy a)) - isPrim _ = True - flowTypeName _ = Nothing - -instance - ( FlowTyped a, - FlowTyped b - ) => - FlowTyped (Either a b) - where - flowTypeName _ = Nothing - flowType _ = - FAlt - (FExactObject (H.fromList [("Left", aFt)])) - (FExactObject (H.fromList [("Right", bFt)])) - where - aFt = callType (Proxy :: Proxy a) - bFt = callType (Proxy :: Proxy b) - -instance - ( FlowTyped a, - FlowTyped b, - FlowTyped c - ) => - FlowTyped (a, b, c) - where - flowTypeName _ = Nothing - flowType _ = FTuple (V.fromList [aFt, bFt, cFt]) - where - aFt = callType (Proxy :: Proxy a) - bFt = callType (Proxy :: Proxy b) - cFt = callType (Proxy :: Proxy c) - -instance - ( FlowTyped a, - FlowTyped b, - FlowTyped c, - FlowTyped d - ) => - FlowTyped (a, b, c, d) - where - flowTypeName _ = Nothing - flowType _ = FTuple (V.fromList [aFt, bFt, cFt, dFt]) - where - aFt = callType (Proxy :: Proxy a) - bFt = callType (Proxy :: Proxy b) - cFt = callType (Proxy :: Proxy c) - dFt = callType (Proxy :: Proxy d) - -instance - ( FlowTyped a, - FlowTyped b, - FlowTyped c, - FlowTyped d, - FlowTyped e - ) => - FlowTyped (a, b, c, d, e) - where - flowTypeName _ = Nothing - flowType _ = FTuple (V.fromList [aFt, bFt, cFt, dFt, eFt]) - where - aFt = callType (Proxy :: Proxy a) - bFt = callType (Proxy :: Proxy b) - cFt = callType (Proxy :: Proxy c) - dFt = callType (Proxy :: Proxy d) - eFt = callType (Proxy :: Proxy e) - -instance FlowTyped Text where - isPrim _ = True - flowType _ = FPrimString - flowTypeName _ = Nothing - -instance FlowTyped TL.Text where - isPrim _ = True - flowType _ = FPrimString - flowTypeName _ = Nothing - -instance {-# OVERLAPS #-} FlowTyped String where - isPrim _ = True - flowType _ = FPrimString - flowTypeName _ = Nothing - -instance FlowTyped Void.Void where - isPrim _ = True - flowType _ = FPrimBottom - flowTypeName _ = Nothing - -instance FlowTyped Char where - isPrim _ = True - flowType _ = FPrimString - flowTypeName _ = Nothing - -instance FlowTyped Bool where - isPrim _ = True - flowType _ = FPrimBoolean - flowTypeName _ = Nothing - -instance FlowTyped A.Value where - isPrim _ = True - flowType _ = FPrimMixed - flowTypeName _ = Nothing - -instance FlowTyped UTCTime where - isPrim _ = False - flowType _ = FPrimString - flowTypeName _ = Nothing - -instance (Typeable (a :: k), Typeable k) => FlowTyped (Fixed a) where - isPrim _ = False - flowType _ = FPrimNumber - flowTypeName _ = Nothing - -instance - ( FlowTyped k, - FlowTyped a, - A.ToJSONKey k - ) => - FlowTyped (HashMap k a) - where - -- XXX this is getting quite incoherent, what makes something "Prim" or not... - isPrim _ = True - - flowType _ = case A.toJSONKey :: A.ToJSONKeyFunction k of - A.ToJSONKeyText {} -> - FObjectMap "key" FPrimString (callType (Proxy :: Proxy a)) - A.ToJSONKeyValue {} -> - FArray - ( FTuple - ( V.fromListN - 2 - [callType (Proxy :: Proxy k), callType (Proxy :: Proxy a)] - ) - ) - - flowTypeName _ = Nothing - -instance (FlowTyped a) => FlowTyped (Set.Set a) where - isPrim _ = False - flowType _ = FArray (callType (Proxy :: Proxy a)) - flowTypeName _ = Nothing - -instance FlowTyped IntSet.IntSet where - isPrim _ = False - flowType _ = FArray FPrimNumber -- (Fix (Prim Number)) - flowTypeName _ = Nothing - -instance (FlowTyped a) => FlowTyped (I.IntMap a) where - isPrim _ = False - flowType _ = - Fix - . Array - . Fix - . Tuple - . V.fromListN 2 - $ [FPrimNumber, callType (Proxy :: Proxy a)] - flowTypeName _ = Nothing - -instance (FlowTyped a) => FlowTyped (HashSet.HashSet a) where - isPrim _ = False - flowType _ = FArray (callType (Proxy :: Proxy a)) - flowTypeName _ = Nothing - --- | This instance is defined recursively. You'll probably need to use --- 'dependencies' to extract a usable definition -instance (FlowTyped a) => FlowTyped (Tree.Tree a) where - isPrim _ = False - flowType _ = - FTuple - ( V.fromList - [ FGenericParam 0, - FArray (callType' (Proxy :: Proxy (Tree.Tree a)) [FGenericParam 0]) - ] - ) - flowTypeName _ = Just "Tree" - flowTypeVars _ = [Flowable (Proxy :: Proxy a)] - -instance FlowTyped () where - isPrim _ = False - flowType _ = FTuple V.empty - flowTypeName _ = Nothing - --- monomorphic numeric instances -$( concat - <$> mapM - ( \ty -> - [d| - instance FlowTyped $ty where - isPrim _ = False - flowType _ = FPrimNumber - flowTypeName _ = Nothing - |] - ) - [ [t|Int|], - [t|Int8|], - [t|Int16|], - [t|Int32|], - [t|Int64|], - [t|Word|], - [t|Word8|], - [t|Word16|], - [t|Word32|], - [t|Word64|], - [t|Float|], - [t|Double|], - [t|Scientific|], - [t|Integer|] - ] - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- | Derive using aeson 'Options'. +-- +-- Does not currently support the 'unwrapUnaryRecords' option. +module Data.Aeson.Flow + ( -- * AST types + FlowTyped(..) + , callType + , FlowTypeF + , FlowType + -- , Fix (..) + , pattern FObject + , pattern FExactObject + , pattern FObjectMap + , pattern FArray + , pattern FTuple + , pattern FLabelledTuple + , pattern FFun + , pattern FAlt + , pattern FPrim + , pattern FPrimBoolean + , pattern FPrimNumber + , pattern FPrimString + , pattern FPrimBottom + , pattern FPrimMixed + , pattern FPrimUnknown + , pattern FPrimNull + , pattern FPrimNever + , pattern FPrimUndefined + , pattern FPrimAny + , pattern FNullable + , pattern FOmitable + , pattern FLiteral + , pattern FTag + , pattern FName + , pattern FGenericParam + , pattern FCallType + -- * Code generation + -- ** Wholesale ES6/flow/typescript modules + , Export + , export + , RenderMode(..) + , RenderOptions(..) + , ModuleOptions(..) + , typeScriptModuleOptions + , flowModuleOptions + , generateModule + , writeModule + , showTypeAs + , exportTypeAs + -- ** Convenience for generating flowtypes from other types + , FlowTyFields(..) + , FlowDeconstructField + -- ** TS specific + , showTypeScriptType + -- ** Flow specific + , showFlowType + -- * Dependencies + , exportsDependencies + , dependencies + -- * Utility + , FlowName(..) + , Flowable(..) + , defaultFlowTypeName + , defaultFlowType + ) where +import Control.Monad.Reader +import Control.Monad.State.Strict +import qualified Data.Aeson as A +import qualified Data.Aeson.Key as AK +import qualified Data.Aeson.KeyMap as AKM +import Data.Aeson.Types ( Options(..) + , SumEncoding(..) + ) +import Data.Eq.Deriving ( deriveEq1 ) +import Data.Fix ( Fix(..) ) +import Data.Fixed ( Fixed ) +import Data.Functor.Classes +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as H +import qualified Data.HashSet as HashSet +import Data.Int +import qualified Data.IntMap.Strict as I +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Monoid as Monoid +import Data.Proxy +import Data.Reflection +import Data.Scientific ( Scientific ) +import qualified Data.Set as Set +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Data.Text.Lazy as TL +import Data.Time ( UTCTime ) +import qualified Data.Tree as Tree +import Data.Typeable +import Data.Vector ( Vector ) +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Data.Void as Void +import Data.Word +import GHC.Generics ( D1 + , Generic + , Meta(..) + , Rep + , from + ) +import GHC.TypeLits +import qualified Generics.SOP as SOP +import qualified Generics.SOP.GGP as SOP +import qualified Text.PrettyPrint.Leijen as PP + +-- | The main AST for flowtypes. +data FlowTypeF a + = Object !(HashMap Text a) + | ExactObject !(HashMap Text a) + | ObjectMap !Text a a + | Array a + | Tuple !(Vector a) + | LabelledTuple !(Vector (Maybe Text, a)) + | Fun !(Vector (Text, a)) a + | Alt a a + | Prim !PrimType + | Nullable a + | Omitable a -- ^ omitable when null or undefined + | Literal !A.Value + | Tag !Text + | GenericParam !Int + | CallType !FlowName [a] + | SomeFlowType !Flowable + | TypeDoc !(Vector Text) a + deriving (Show, Eq, Functor, Traversable, Foldable) + +-- | A primitive flow/javascript type +data PrimType + = Boolean + | Number + | String + | Null + | Undefined + | Bottom -- ^ uninhabited type; @never@ in typescript, and @empty@ in flow + | Mixed -- ^ @unknown@ in typescript, @mixed@ in flow + | Any + deriving (Show, Read, Eq, Ord) + +-- | A name for a flowtyped data-type. These are returned by 'dependencies'. +data FlowName where + FlowName ::(FlowTyped a) => Proxy a -> Text -> FlowName + +data Flowable where + Flowable ::(FlowTyped a) => Proxy a -> Flowable + +data Showy f a = forall s . Reifies s (Int -> a -> ShowS) => Showy + (f (Inj s a)) +instance Show1 (Showy FlowTypeF) where + liftShowsPrec _ _ i (Showy a) = showsPrec i a + + +-------------------------------------------------------------------------------- +-- Magical newtype for injecting showsPrec into any arbitrary Show + +inj :: Proxy s -> a -> Inj s a +inj _ = Inj + +newtype Inj s a = Inj a +-- needs UndecidableInstances + +instance Reifies s (Int -> a -> ShowS) => Show (Inj s a) where + showsPrec i (Inj a) = reflect (Proxy :: Proxy s) i a + +-------------------------------------------------------------------------------- + +data RenderMode = RenderTypeScript | RenderFlow + deriving (Eq, Show) + +data RenderOptions = RenderOptions + { renderMode :: !RenderMode + } + deriving (Eq, Show) + +instance Show FlowName where + show (FlowName _ t) = show t + +instance Eq FlowName where + FlowName _t0 n0 == FlowName _t1 n1 = n0 == n1 + -- case eqT :: Maybe (t0 :~: t1) of + -- Just Refl -> (t0, n0) == (t1, n1) + -- Nothing -> False + +instance Ord FlowName where + FlowName _t0 n0 `compare` FlowName _t1 n1 = n0 `compare` n1 + -- XXX this breaks using (typeRep t0, n0) `compare` (typeRep t1, n1) for some + -- reason... dunno why + +instance Show Flowable where + show (Flowable t) = show (typeRep t) + +instance Eq Flowable where + Flowable a == Flowable b = typeRep a == typeRep b + +instance Ord Flowable where + Flowable a `compare` Flowable b = typeRep a `compare` typeRep b + +-- XXX: vector >= 0.12 has Eq1 vector which allows us to use eq for Fix +-- FlowTypeF and related types + +-------------------------------------------------------------------------------- + +pattern FObject :: HashMap Text FlowType -> FlowType +pattern FObject x = Fix (Object x) + +pattern FExactObject :: HashMap Text FlowType -> FlowType +pattern FExactObject x = Fix (ExactObject x) + +pattern FObjectMap :: Text -> FlowType -> FlowType -> FlowType +pattern FObjectMap keyName keyType vals = Fix (ObjectMap keyName keyType vals) + +pattern FArray :: FlowType -> FlowType +pattern FArray a = Fix (Array a) + +pattern FTuple :: Vector FlowType -> FlowType +pattern FTuple a = Fix (Tuple a) + +pattern FLabelledTuple :: Vector (Maybe Text, FlowType) -> FlowType +pattern FLabelledTuple a = Fix (LabelledTuple a) + +pattern FFun :: Vector (Text, FlowType) -> FlowType -> FlowType +pattern FFun v t = Fix (Fun v t) + +pattern FAlt :: FlowType -> FlowType -> FlowType +pattern FAlt a b = Fix (Alt a b) + +pattern FPrim :: PrimType -> FlowType +pattern FPrim a = Fix (Prim a) + +pattern FPrimBoolean :: FlowType +pattern FPrimBoolean = FPrim Boolean + +pattern FPrimNumber :: FlowType +pattern FPrimNumber = FPrim Number + +pattern FPrimString :: FlowType +pattern FPrimString = FPrim String + +pattern FPrimBottom :: FlowType +pattern FPrimBottom = FPrim Bottom + +pattern FPrimMixed :: FlowType +pattern FPrimMixed = FPrim Mixed + +pattern FPrimUnknown :: FlowType +pattern FPrimUnknown = FPrim Mixed + +pattern FPrimAny :: FlowType +pattern FPrimAny = FPrim Any + +pattern FPrimNever :: FlowType +pattern FPrimNever = FPrim Bottom + +pattern FPrimNull :: FlowType +pattern FPrimNull = FPrim Null + +pattern FPrimUndefined :: FlowType +pattern FPrimUndefined = FPrim Undefined + +pattern FNullable :: FlowType -> FlowType +pattern FNullable a = Fix (Nullable a) + +pattern FOmitable :: FlowType -> FlowType +pattern FOmitable a = Fix (Omitable a) + +pattern FLiteral :: A.Value -> FlowType +pattern FLiteral a = Fix (Literal a) + +pattern FTag :: Text -> FlowType +pattern FTag a = Fix (Tag a) + +pattern FName :: FlowName -> FlowType +pattern FName a = Fix (CallType a []) + +pattern FGenericParam :: Int -> FlowType +pattern FGenericParam a = Fix (GenericParam a) + +pattern FCallType :: FlowName -> [FlowType] -> FlowType +pattern FCallType f xs = Fix (CallType f xs) + +pattern FTypeDoc :: Vector Text -> FlowType -> FlowType +pattern FTypeDoc f xs = Fix (TypeDoc f xs) + +-------------------------------------------------------------------------------- + +instance Show1 FlowTypeF where + liftShowsPrec sp sl i a = + liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a))) + +type FlowType = Fix FlowTypeF + +text :: Text -> PP.Doc +text = PP.text . T.unpack + +squotes :: Text -> PP.Doc +squotes = PP.squotes . text . T.replace "'" "\\'" + +type Poly = ReaderT RenderOptions (Reader [Flowable]) + +ppAlts :: [FlowType] -> FlowType -> Poly PP.Doc +ppAlts alts (Fix f) = case f of + Alt a b -> ppAlts (a : alts) b + x -> PP.align . sep <$> mapM pp (reverse (Fix x : alts)) + where + sep [x] = x + sep (x : xs) = x PP.<+> PP.string "|" PP.<$> sep xs + sep _ = PP.empty + +braceList :: [PP.Doc] -> PP.Doc +braceList = + (\s -> PP.lbrace PP. s PP. PP.rbrace) + . PP.align + . PP.sep + . PP.punctuate PP.comma + +braceBarList :: [PP.Doc] -> PP.Doc +braceBarList = + (\s -> PP.text "{|" PP. s PP. PP.text "|}") + . PP.align + . PP.sep + . PP.punctuate PP.comma + +ppJson :: A.Value -> PP.Doc +ppJson v = case v of + A.Array a -> PP.list (map ppJson (V.toList a)) + A.String t -> squotes t + A.Number n -> PP.string (show n) + A.Bool t -> if t then PP.string "true" else PP.string "false" + A.Null -> PP.string "null" + A.Object obj -> braceBarList + (map + (\(name, fty) -> + PP.space + PP.<> text (AK.toText name) + PP.<+> PP.colon + PP.<+> ppJson fty + PP.<> PP.space + ) + (AKM.toList obj) + ) + +mayWrap :: FlowType -> PP.Doc -> PP.Doc +mayWrap (Fix f) x = case f of + Nullable _ -> PP.parens x + Omitable _ -> PP.parens x + Alt _ _ -> PP.parens x + Array _ -> PP.parens x + _ -> x + +ppObject :: HashMap Text FlowType -> Poly [PP.Doc] +ppObject = mapM ppField . H.toList + where + ppField (name, fty) = do + case fty of + Fix (Omitable fty') -> + -- key?: type + (\fty'' -> text name PP.<> PP.text "?" PP.<> PP.colon PP.<+> fty'') + <$> pp fty' + + fty' -> + -- key: type + (\fty'' -> text name PP.<> PP.colon PP.<+> fty'') <$> pp fty' + +polyVarNames :: [Text] +polyVarNames = + map T.singleton ['A' .. 'Z'] + ++ zipWith (\i t -> t `T.append` T.pack (show i)) [0 :: Int ..] polyVarNames + +pp :: FlowType -> Poly PP.Doc +pp (Fix ft) = case ft of + ObjectMap keyName keyType a -> do + keyTy <- pp keyType + r <- pp a + pure + (braceList + [ PP.brackets (text keyName PP.<> PP.text ":" PP.<+> keyTy) + PP.<> PP.colon + PP.<+> r + ] + ) + + Object hm -> braceList <$> ppObject hm + + ExactObject hm -> do + mode <- asks renderMode + case mode of + RenderFlow -> braceBarList <$> ppObject hm + RenderTypeScript -> braceList <$> ppObject hm + + -- x[] + Array a -> (\r -> mayWrap a r PP.<> PP.string "[]") <$> pp a + + -- [x, y, z] + Tuple t -> PP.list <$> mapM pp (V.toList t) + + -- [l1: x, y, l2: z] + LabelledTuple t -> PP.list <$> mapM + (\(mlbl, ty) -> case mlbl of + Just lbl -> ((text lbl PP.<> PP.string ":") PP.<+>) <$> pp ty + Nothing -> pp ty + ) + (V.toList t) + + Alt a b -> ppAlts [a] b + + Prim pt -> do + mode <- asks renderMode + return $ case pt of + Boolean -> PP.text "boolean" + Number -> PP.text "number" + String -> PP.text "string" + Null -> PP.text "null" + Undefined -> PP.text "undefined" + Any -> PP.text "any" + Mixed -> case mode of + RenderFlow -> PP.text "mixed" + RenderTypeScript -> PP.text "unknown" + Bottom -> case mode of + RenderFlow -> PP.text "empty" + RenderTypeScript -> PP.text "never" + + Nullable a -> + -- n.b. there is no 'undefined' in json. void is undefined | null in both ts + -- and flow (and ?x syntax for void|x) + (\a' -> PP.text "null" PP.<+> PP.string "|" PP.<+> a') <$> pp a + + Omitable a -> pp (FNullable a) + + Literal a -> return (ppJson a) + + Tag t -> return (squotes t) + + GenericParam ix -> return (text (polyVarNames !! ix)) + + CallType (FlowName _ t) [] -> return (text t) + + CallType (FlowName _ t) args -> do + vs <- mapM pp args + return (text t PP.<> PP.angles (PP.hsep (PP.punctuate PP.comma vs))) + + TypeDoc _doc t -> pp t + + _ -> return (PP.string (show ft)) + +-- | Pretty-print a flowtype in flowtype syntax +renderTypeWithOptions :: RenderOptions -> FlowType -> [Flowable] -> PP.Doc +renderTypeWithOptions opts ft params = + (pp ft `runReaderT` opts) `runReader` params + +-- | Pretty-print a flowtype in flowtype syntax +showFlowType :: FlowType -> [Flowable] -> Text +showFlowType ft params = T.pack . show $ renderTypeWithOptions + RenderOptions { renderMode = RenderFlow } + ft + params + +-- | Pretty-print a flowtype in flowtype syntax +showTypeScriptType :: FlowType -> [Flowable] -> Text +showTypeScriptType ft params = T.pack . show $ renderTypeWithOptions + RenderOptions { renderMode = RenderTypeScript } + ft + params + +-------------------------------------------------------------------------------- +-- Module exporting + +-- | Generate a @ export type @ declaration. +exportTypeAs :: RenderOptions -> Text -> FlowType -> [Flowable] -> Text +exportTypeAs opts = showTypeAs opts True + +-- | Generate a @ type @ declaration, possibly an export. +showTypeAs :: RenderOptions -> Bool -> Text -> FlowType -> [Flowable] -> Text +showTypeAs opts isExport name ft params = + T.pack + . render + $ PP.string (if isExport then "export type " else "type ") + PP.<> text name + PP.<> renderedParams + PP.<+> text "=" + PP.<+> renderedTypeDecl + PP.<> text ";" + PP.<> PP.linebreak + where + renderedTypeDecl = renderTypeWithOptions opts ft params + renderedParams + | null params = mempty + | otherwise = PP.angles + (PP.hsep + (PP.punctuate PP.comma (map text (take (length params) polyVarNames))) + ) + + render = ($ []) . PP.displayS . PP.renderPretty 1.0 80 + +-- | Compute all the dependencies of a 'FlowTyped' thing, including itself. +dependencies :: (FlowTyped a) => Proxy a -> Set.Set FlowName +dependencies p0 = + (case flowTypeName p0 of + Just t -> Set.insert (FlowName p0 t) + Nothing -> id + ) + (M.foldl' Set.union Set.empty (transitiveDeps (Flowable p0) M.empty)) + where + flowNameToFlowable (FlowName fn _) = Flowable fn + + immediateDeps :: FlowType -> Set.Set FlowName + immediateDeps (FCallType n tys) = + Set.insert n (Set.unions (map immediateDeps tys)) + immediateDeps (Fix p) = foldMap immediateDeps p + + transitiveDeps + :: Flowable + -> M.Map Flowable (Set.Set FlowName) + -> M.Map Flowable (Set.Set FlowName) + transitiveDeps fpf@(Flowable p) acc + | fpf `M.notMember` acc + = let imms = immediateDeps (flowType p) + withThis = M.insert fpf imms acc + in Set.foldr' (transitiveDeps . flowNameToFlowable) withThis imms + | otherwise + = acc + +data ModuleOptions = ModuleOptions + { -- | You might want to change this to include e.g. flow-runtime + pragmas :: [Text] + , header :: [Text] + , exportDeps :: Bool + , computeDeps :: Bool + , renderOptions :: RenderOptions + } + deriving (Eq, Show) + +flowModuleOptions :: ModuleOptions +flowModuleOptions = ModuleOptions + { pragmas = ["// @flow"] + , header = ["This module has been generated by aeson-flowtyped."] + , exportDeps = True + , computeDeps = True + , renderOptions = RenderOptions { renderMode = RenderFlow } + } + +typeScriptModuleOptions :: ModuleOptions +typeScriptModuleOptions = ModuleOptions + { pragmas = [] + , header = ["This module has been generated by aeson-flowtyped."] + , exportDeps = True + , computeDeps = True + , renderOptions = RenderOptions { renderMode = RenderTypeScript } + } + +data Export where + Export ::FlowTyped a => Proxy a -> Export + +export :: forall a . FlowTyped a => Export +export = Export (Proxy :: Proxy a) + +instance Eq Export where + Export p0 == Export p1 = + flowTypeName p0 == flowTypeName p1 || typeRep p0 == typeRep p1 + +exportsDependencies :: [Export] -> Set.Set FlowName +exportsDependencies = foldMap $ \e -> case e of + Export a -> dependencies a + +generateModule :: ModuleOptions -> [Export] -> Text +generateModule opts exports = + T.unlines + $ (\m -> + (pragmas opts ++ map ("// " `T.append`) (header opts)) ++ (T.empty : m) + ) + . map flowDecl + . flowNames + $ exports + where + flowNames = if computeDeps opts + then Set.toList . exportsDependencies + else catMaybes . map + (\ex -> case ex of + Export p -> FlowName p <$> flowTypeName p + ) + + flowDecl (FlowName p name) = if Export p `elem` exports || exportDeps opts + then showTypeAs (renderOptions opts) True name (flowType p) (flowTypeVars p) + else showTypeAs (renderOptions opts) + False + name + (flowType p) + (flowTypeVars p) + +writeModule :: ModuleOptions -> FilePath -> [Export] -> IO () +writeModule opts path = TIO.writeFile path . generateModule opts + +-------------------------------------------------------------------------------- + +type family FlowDeconstructField (k :: t) :: (Symbol, *) +type instance FlowDeconstructField '(a, b) = '(a, b) + +-- | Useful for declaring flowtypes from type-level key/value sets, like +-- +-- @ +-- FlowTyFields :: FlowTyFields Person '['("name", String), '("email", String)] +-- @ +data FlowTyFields :: * -> [k] -> * where + FlowTyFields ::FlowTyFields k fs + +class ReifyFlowTyFields a where + reifyFlowTyFields :: Proxy a -> HashMap Text FlowType -> HashMap Text FlowType + +instance ReifyFlowTyFields '[] where + reifyFlowTyFields _ = id + +instance ( FlowDeconstructField x ~ '(k, v) + , KnownSymbol k + , FlowTyped v + , ReifyFlowTyFields xs + ) => + ReifyFlowTyFields (x:xs) where + reifyFlowTyFields _ acc = + reifyFlowTyFields (Proxy :: Proxy xs) + $! H.insert (T.pack (symbolVal (Proxy :: Proxy k))) + (flowType (Proxy :: Proxy v)) + acc + +instance (FlowTyped a, ReifyFlowTyFields (fs :: [k]), Typeable fs, Typeable k) => FlowTyped (FlowTyFields a fs) where + flowType _ = FExactObject (reifyFlowTyFields (Proxy :: Proxy fs) H.empty) + flowTypeName _ = flowTypeName (Proxy :: Proxy a) + +-------------------------------------------------------------------------------- + +callType' :: (FlowTyped a) => Proxy a -> [FlowType] -> FlowType +callType' p args = case flowTypeName p of + Just n -> FCallType (FlowName p n) args + Nothing -> flowType p + +callType :: forall a . FlowTyped a => Proxy a -> FlowType +callType p = callType' p (map (\(Flowable t) -> callType t) (flowTypeVars p)) + +class Typeable a => FlowTyped a where + flowType :: Proxy a -> FlowType + flowTypeName :: Proxy a -> Maybe Text + + flowTypeVars :: Proxy a -> [Flowable] + flowTypeVars _ = [] + + flowOptions :: Proxy a -> Options + flowOptions _ = A.defaultOptions + + isPrim :: Proxy a -> Bool + isPrim _ = False + + default flowType + :: (SOP.GDatatypeInfo a, SOP.All2 FlowTyped (SOP.GCode a)) + => Proxy a + -> FlowType + flowType p = flowTypeFromSOP (flowOptions p) (SOP.gdatatypeInfo p) + + default flowTypeName + :: (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name) + => Proxy a + -> Maybe Text + flowTypeName = defaultFlowTypeName + +-- | 'flowType' using 'SOP.HasDatatypeInfo' +defaultFlowType + :: (SOP.HasDatatypeInfo a, SOP.All2 FlowTyped (SOP.Code a)) + => Options + -> Proxy a + -> FlowType +defaultFlowType opts p = flowTypeFromSOP opts (SOP.datatypeInfo p) + +flowTypeFromSOP + :: SOP.All2 FlowTyped ty => Options -> SOP.DatatypeInfo ty -> FlowType +flowTypeFromSOP opts di = case comments of + [] -> ft + _ -> FTypeDoc (V.fromList comments) ft + where + (ft, comments) = + (case di of + SOP.ADT moduleName typeName constrInfos _strictness -> do + modify' (moduleComment moduleName :) + modify' (typeComment typeName :) + pure . foldr1 FAlt $! case constrsKind constrInfos 0 0 0 True of + SumRecords -> sumEncode constrInfos + SumConstructors -> sumEncode constrInfos + SumNullaryConstructors -> sumNullaryEncode constrInfos + SingleRecord -> singleEncode constrInfos + SingleConstructor -> singleEncode constrInfos + SingleNullaryConstructor -> [FTuple V.empty] + Unsupported -> + error $ "aeson-flowtyped: Unsupported type " ++ show typeName + + SOP.Newtype moduleName typeName constrInfo -> do + modify' (moduleComment moduleName :) + modify' (typeComment typeName :) + case constrInfo of + + (SOP.Constructor constrName :: SOP.ConstructorInfo '[x]) -> do + modify' (constrComment constrName :) + pure (callType (Proxy :: Proxy x)) + + SOP.Record constrName ((SOP.FieldInfo _fname :: SOP.FieldInfo x) SOP.:* SOP.Nil) + -> do + modify' (constrComment constrName :) + pure (callType (Proxy :: Proxy x)) + ) + `runState` [] + + constrsKind + :: SOP.NP SOP.ConstructorInfo ty + -> Int -- ^ total number of record or plain constructors + -> Int -- ^ number of record constructors + -> Int -- ^ number of plain constructors + -> Bool -- ^ whether every constructor is nullary + -> ConstructorsKind + constrsKind SOP.Nil !total !recs !plains !allNullary + | recs == 1 && plains == 0 = SingleRecord + | plains == 1 && recs == 0 = if allNullary + then SingleNullaryConstructor + else SingleConstructor + | recs == total && plains == 0 = SumRecords + | plains == total && recs == 0 = if allNullary + then SumNullaryConstructors + else SumConstructors + | otherwise = Unsupported + constrsKind (constr SOP.:* rest) total recs plains allNullary = + case constr of + (SOP.Constructor{} :: SOP.ConstructorInfo flds) -> constrsKind + rest + (total + 1) + recs + (plains + 1) + (allNullary && isNullary @flds) + + (SOP.Record{} :: SOP.ConstructorInfo flds) -> constrsKind + rest + (total + 1) + (recs + 1) + plains + (allNullary && isNullary @flds) + + _ -> Unsupported + + sumEncode, singleEncode, sumNullaryEncode + :: SOP.All2 FlowTyped ty => SOP.NP SOP.ConstructorInfo ty -> [FlowType] + sumEncode constrsNP = SOP.hcfoldMap + (Proxy :: Proxy (SOP.All FlowTyped)) + (\case + (SOP.Constructor constrName :: SOP.ConstructorInfo xs) -> + let + value = + let tuple = V.fromList $! SOP.hcfoldMap + (Proxy :: Proxy FlowTyped) + (\(Proxy :: SOP.Proxy x) -> [callType (Proxy :: Proxy x)]) + (SOP.hpure Proxy :: SOP.NP Proxy xs) + in case V.length tuple of + 1 -> V.head tuple + _ -> FTuple tuple + + hasContents = Monoid.getAny $! SOP.hcfoldMap + (Proxy :: Proxy SOP.Top) + (\_ -> Monoid.Any True) + (SOP.hpure Proxy :: SOP.NP Proxy xs) + in + case sumEncoding opts of + TaggedObject (T.pack -> tagFld) contentsFld + | hasContents + -> [ FExactObject + (H.fromList + [ (tagFld, renderConstrTag constrName) + , (T.pack contentsFld, value) + ] + ) + ] + | otherwise + -> [ FExactObject + (H.singleton tagFld (renderConstrTag constrName)) + ] + UntaggedValue -> [value] + ObjectWithSingleField -> + [ FExactObject + (H.fromList + [(T.pack (constructorTagModifier opts constrName), value)] + ) + ] + TwoElemArray -> + [FTuple (V.fromListN 2 [renderConstrTag constrName, value])] + + SOP.Record constrName flds -> + let + fldsList :: H.HashMap Text FlowType + fldsList = + H.fromList + $! SOP.hcfoldMap + (Proxy :: Proxy FlowTyped) + (\(SOP.FieldInfo fname :: SOP.FieldInfo x) -> + [ ( T.pack (fieldLabelModifier opts fname) + , callType (Proxy :: Proxy x) + ) + ] + ) + flds + in + case sumEncoding opts of + -- The contents field is not used here but the tag one is + TaggedObject (T.pack -> tagFld) _contentsFld -> + [ FExactObject + (H.insert tagFld (renderConstrTag constrName) fldsList) + ] + UntaggedValue -> [FExactObject fldsList] + ObjectWithSingleField -> + [ FExactObject + (H.singleton + (T.pack (constructorTagModifier opts constrName)) + (FExactObject fldsList) + ) + ] + TwoElemArray -> + [ FTuple + (V.fromListN + 2 + [renderConstrTag constrName, FExactObject fldsList] + ) + ] + SOP.Infix{} -> + error "aeson-flowtyped: Unsupported use of infix constructor" + ) + constrsNP + + singleEncode (constr SOP.:* SOP.Nil) = case constr of + (SOP.Constructor _constrName :: SOP.ConstructorInfo xs) -> + [ FTuple . V.fromList $! SOP.hcfoldMap + (Proxy :: Proxy FlowTyped) + (\(Proxy :: SOP.Proxy x) -> [callType (Proxy :: Proxy x)]) + (SOP.hpure Proxy :: SOP.NP Proxy xs) + ] + SOP.Record _constrName flds -> + [ FExactObject + $! H.fromList + $! SOP.hcfoldMap + (Proxy :: Proxy FlowTyped) + (\(SOP.FieldInfo fname :: SOP.FieldInfo x) -> + [ ( T.pack (fieldLabelModifier opts fname) + , callType (Proxy :: Proxy x) + ) + ] + ) + flds + ] + SOP.Infix{} -> + error "aeson-flowtyped: Unsupported use of infix constructor" + singleEncode _ = + error "aeson-flowtyped: Errorneous detection of single constructor" + + sumNullaryEncode constrsNP + | allNullaryToStringTag opts + = [ FLiteral (A.String (T.pack (constructorTagModifier opts tag))) + | tag <- SOP.hcfoldMap (Proxy :: Proxy SOP.Top) + (\(SOP.Constructor constrName) -> [constrName]) + constrsNP + ] + | otherwise + = [ nullarySumObject (T.pack (constructorTagModifier opts tag)) + | tag <- SOP.hcfoldMap (Proxy :: Proxy SOP.Top) + (\(SOP.Constructor constrName) -> [constrName]) + constrsNP + ] + + nullarySumObject tagValue = case sumEncoding opts of + TaggedObject (T.pack -> tagFld) _contentsFld -> + FExactObject (H.singleton tagFld (FLiteral (A.String tagValue))) + UntaggedValue -> FTuple V.empty + ObjectWithSingleField -> + FExactObject (H.singleton tagValue (FTuple V.empty)) + TwoElemArray -> + FTuple (V.fromListN 2 [FLiteral (A.String tagValue), FTuple V.empty]) + + renderConstrTag = FLiteral . A.String . T.pack . constructorTagModifier opts + + moduleComment s = T.concat ["Origin module: `", T.pack s, "`"] + typeComment s = T.concat ["Origin type: ", T.pack s] + constrComment s = T.concat ["Origin constructor: ", T.pack s] + + isNullary :: forall xs . SOP.SListI xs => Bool + isNullary = SOP.lengthSList (Proxy :: Proxy xs) == 0 + + +data ConstructorsKind + = SumRecords + | SumConstructors + | SumNullaryConstructors + | SingleRecord + | SingleConstructor + | SingleNullaryConstructor + | Unsupported + +-- | 'flowTypeName' using 'Generic' +defaultFlowTypeName + :: (Generic a, Rep a ~ D1 ('MetaData name mod pkg t) c, KnownSymbol name) + => Proxy a + -> Maybe Text +defaultFlowTypeName p = + Just . cleanup . T.pack . symbolVal . pGetName . fmap from $ p + where + pGetName :: Proxy (D1 ( 'MetaData name mod pkg t) c x) -> Proxy name + pGetName _ = Proxy + cleanup = T.replace "'" "_" -- I think this is the only illegal token in JS + -- that's allowed in Haskell, other than type + -- operators... TODO, rename type operators + +-------------------------------------------------------------------------------- +-- Instances + +instance (FlowTyped a) => FlowTyped [a] where + flowType _ = FArray (callType (Proxy :: Proxy a)) + isPrim _ = True + flowTypeName _ = Nothing + +instance (FlowTyped a) => FlowTyped (Vector a) where + flowType _ = FArray (callType (Proxy :: Proxy a)) + isPrim _ = True + flowTypeName _ = Nothing + +instance (FlowTyped a) => FlowTyped (VU.Vector a) where + flowType _ = FArray (callType (Proxy :: Proxy a)) + isPrim _ = True + flowTypeName _ = Nothing + +instance (FlowTyped a) => FlowTyped (VS.Vector a) where + flowType _ = FArray (callType (Proxy :: Proxy a)) + isPrim _ = True + flowTypeName _ = Nothing + +instance ( FlowTyped a + , FlowTyped b + ) => FlowTyped (a, b) where + flowTypeName _ = Nothing + flowType _ = FTuple (V.fromList [aFt, bFt]) + where + aFt = callType (Proxy :: Proxy a) + bFt = callType (Proxy :: Proxy b) + +instance (FlowTyped a) => FlowTyped (Maybe a) where + flowType _ = FNullable (callType (Proxy :: Proxy a)) + isPrim _ = True + flowTypeName _ = Nothing + +instance ( FlowTyped a + , FlowTyped b) => + FlowTyped (Either a b) where + flowTypeName _ = Nothing + flowType _ = FAlt (FExactObject (H.fromList [("Left", aFt)])) + (FExactObject (H.fromList [("Right", bFt)])) + where + aFt = callType (Proxy :: Proxy a) + bFt = callType (Proxy :: Proxy b) + +instance ( FlowTyped a + , FlowTyped b + , FlowTyped c) => + FlowTyped (a, b, c) where + flowTypeName _ = Nothing + flowType _ = FTuple (V.fromList [aFt, bFt, cFt]) + where + aFt = callType (Proxy :: Proxy a) + bFt = callType (Proxy :: Proxy b) + cFt = callType (Proxy :: Proxy c) + +instance ( FlowTyped a + , FlowTyped b + , FlowTyped c + , FlowTyped d + ) => + FlowTyped (a, b, c, d) where + flowTypeName _ = Nothing + flowType _ = FTuple (V.fromList [aFt, bFt, cFt, dFt]) + where + aFt = callType (Proxy :: Proxy a) + bFt = callType (Proxy :: Proxy b) + cFt = callType (Proxy :: Proxy c) + dFt = callType (Proxy :: Proxy d) + +instance ( FlowTyped a + , FlowTyped b + , FlowTyped c + , FlowTyped d + , FlowTyped e + ) => + FlowTyped (a, b, c, d, e) where + flowTypeName _ = Nothing + flowType _ = FTuple (V.fromList [aFt, bFt, cFt, dFt, eFt]) + where + aFt = callType (Proxy :: Proxy a) + bFt = callType (Proxy :: Proxy b) + cFt = callType (Proxy :: Proxy c) + dFt = callType (Proxy :: Proxy d) + eFt = callType (Proxy :: Proxy e) + +instance FlowTyped Text where + isPrim _ = True + flowType _ = FPrimString + flowTypeName _ = Nothing + +instance FlowTyped TL.Text where + isPrim _ = True + flowType _ = FPrimString + flowTypeName _ = Nothing + +instance {-# OVERLAPS #-} FlowTyped String where + isPrim _ = True + flowType _ = FPrimString + flowTypeName _ = Nothing + +instance FlowTyped Void.Void where + isPrim _ = True + flowType _ = FPrimBottom + flowTypeName _ = Nothing + +instance FlowTyped Char where + isPrim _ = True + flowType _ = FPrimString + flowTypeName _ = Nothing + +instance FlowTyped Bool where + isPrim _ = True + flowType _ = FPrimBoolean + flowTypeName _ = Nothing + +instance FlowTyped A.Value where + isPrim _ = True + flowType _ = FPrimMixed + flowTypeName _ = Nothing + +instance FlowTyped UTCTime where + isPrim _ = False + flowType _ = FPrimString + flowTypeName _ = Nothing + +instance (Typeable (a :: k), Typeable k) => FlowTyped (Fixed a) where + isPrim _ = False + flowType _ = FPrimNumber + flowTypeName _ = Nothing + +instance ( FlowTyped k + , FlowTyped a + , A.ToJSONKey k + ) => FlowTyped (HashMap k a) where + -- XXX this is getting quite incoherent, what makes something "Prim" or not... + isPrim _ = True + + flowType _ = case A.toJSONKey :: A.ToJSONKeyFunction k of + A.ToJSONKeyText{} -> + FObjectMap "key" FPrimString (callType (Proxy :: Proxy a)) + + A.ToJSONKeyValue{} -> FArray + (FTuple + (V.fromListN + 2 + [callType (Proxy :: Proxy k), callType (Proxy :: Proxy a)] + ) + ) + + flowTypeName _ = Nothing + +instance (FlowTyped a) => FlowTyped (Set.Set a) where + isPrim _ = False + flowType _ = FArray (callType (Proxy :: Proxy a)) + flowTypeName _ = Nothing + +instance FlowTyped IntSet.IntSet where + isPrim _ = False + flowType _ = FArray FPrimNumber -- (Fix (Prim Number)) + flowTypeName _ = Nothing + +instance (FlowTyped a) => FlowTyped (I.IntMap a) where + isPrim _ = False + flowType _ = + Fix + . Array + . Fix + . Tuple + . V.fromListN 2 + $ [FPrimNumber, callType (Proxy :: Proxy a)] + flowTypeName _ = Nothing + +instance (FlowTyped a) => FlowTyped (HashSet.HashSet a) where + isPrim _ = False + flowType _ = FArray (callType (Proxy :: Proxy a)) + flowTypeName _ = Nothing + +-- | This instance is defined recursively. You'll probably need to use +-- 'dependencies' to extract a usable definition +instance (FlowTyped a) => FlowTyped (Tree.Tree a) where + isPrim _ = False + flowType _ = FTuple + (V.fromList + [ FGenericParam 0 + , FArray (callType' (Proxy :: Proxy (Tree.Tree a)) [FGenericParam 0]) + ] + ) + flowTypeName _ = Just "Tree" + flowTypeVars _ = [Flowable (Proxy :: Proxy a)] + +instance FlowTyped () where + isPrim _ = False + flowType _ = FTuple V.empty + flowTypeName _ = Nothing + +-- monomorphic numeric instances +$(concat <$> mapM + (\ty -> + [d| + instance FlowTyped $ty where + isPrim _ = False + flowType _ = FPrimNumber + flowTypeName _ = Nothing |]) + [ [t|Int|], [t|Int8|], [t|Int16|], [t|Int32|], [t|Int64|] + , [t|Word|], [t|Word8|], [t|Word16|], [t|Word32|], [t|Word64|] + , [t|Float|], [t|Double|], [t|Scientific|] + ]) deriveEq1 ''FlowTypeF