aeson-flowtyped 0.9.1 → 0.12.0
raw patch · 3 files changed
+664/−325 lines, 3 filesdep +data-fixdep +deriving-compatdep +mtldep −transformersdep ~base
Dependencies added: data-fix, deriving-compat, mtl
Dependencies removed: transformers
Dependency ranges changed: base
Files
- aeson-flowtyped.cabal +23/−22
- src/Data/Aeson/Flow.hs +618/−289
- test/Spec.hs +23/−14
aeson-flowtyped.cabal view
@@ -1,11 +1,7 @@--- This file has been generated from package.yaml by hpack version 0.17.0.------ see: https://github.com/sol/hpack- name: aeson-flowtyped-version: 0.9.1-synopsis: Create Flow type definitions from Haskell data types.-description: Create Flow type definitions from Haskell data types.+version: 0.12.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@@ -24,19 +20,21 @@ hs-source-dirs: src build-depends:- base >= 4.9 && <4.11- , aeson >= 0.8- , vector- , text- , recursion-schemes+ aeson >=0.8+ , base >= 4.11 && < 4.16 , containers+ , data-fix+ , deriving-compat+ , free+ , recursion-schemes+ , reflection+ , scientific+ , text , time+ , mtl , unordered-containers- , reflection+ , vector , wl-pprint- , free- , scientific- , transformers exposed-modules: Data.Aeson.Flow other-modules:@@ -46,17 +44,20 @@ test-suite aeson-flowtyped type: exitcode-stdio-1.0 main-is: Spec.hs+ other-modules:+ Paths_aeson_flowtyped hs-source-dirs: test build-depends:- base >= 4.9 && <4.11- , aeson >= 0.8- , vector- , text- , recursion-schemes- , containers+ aeson >=0.8 , aeson-flowtyped+ , base+ , containers+ , data-fix+ , recursion-schemes , tasty , tasty-hunit+ , text , unordered-containers+ , vector default-language: Haskell2010
src/Data/Aeson/Flow.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -15,50 +17,86 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- | Derive <https://flow.org/ Flow types> using aeson 'Options'.+--+-- Does not currently support the 'unwrapUnaryRecords' option. module Data.Aeson.Flow ( -- * AST types FlowTyped (..)+ , callType+ , FlowTypeF , FlowType- , Fix (..)- , FlowTypeF (..)+ -- , 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- , FlowModuleOptions (..)- , defaultFlowModuleOptions- , Export (..)- , generateFlowModule- , writeFlowModule- , exportFlowTypeAs- , flowTypeAs- -- * Utility functions+ , Export+ , export+ , RenderMode (..)+ , RenderOptions (..)+ , ModuleOptions (..)+ , typeScriptModuleOptions+ , flowModuleOptions+ , generateModule+ , writeModule+ , showTypeAs+ , exportTypeAs+ -- ** TS specific+ , showTypeScriptType+ -- ** Flow specific , showFlowType- , dependencies+ -- * Dependencies , exportsDependencies- -- * Internals- , defaultFlowType- , defaultFlowTypeName+ , dependencies+ -- * Utility+ , FlowCallable , FlowName (..)- , PrimType (..)- , GFlowTyped- , FlowTypeI- , Info (..)- , Var (..)+ , Flowable (..)+ , FlowTyFields (..)+ , FlowDeconstructField , Typeable , typeRep ) where import Control.Monad-import Control.Monad.Trans.State.Strict+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.Foldable import Data.Functor.Classes import Data.Functor.Compose import Data.Functor.Foldable hiding (fold)@@ -69,8 +107,11 @@ 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)@@ -88,12 +129,57 @@ import qualified Data.Vector.Unboxed as VU import qualified Data.Void as Void import Data.Word-import Data.Maybe-import Debug.Trace 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 @@ -102,40 +188,32 @@ 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 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- -------------------------------------------------------------------------------- --- | A primitive flow/javascript type-data PrimType- = Boolean- | Number- | String- | Void- | Mixed- | Any- deriving (Show, Read, Eq, Ord)+data RenderMode = RenderTypeScript | RenderFlow+ deriving (Eq, Show) --- | A name for a flowtyped data-type. These are returned by 'dependencies'.-data FlowName where- FlowName :: (Typeable a, FlowTyped a) => Proxy a -> Text -> FlowName+data RenderOptions = RenderOptions+ { renderMode :: !RenderMode+ } deriving (Eq, Show) instance Show FlowName where show (FlowName _ t) = show t instance Eq FlowName where- FlowName _ n0 == FlowName _ n1 = n0 == n1+ 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 _ n0 `compare` FlowName _ n1 = compare n0 n1--data Flowable where- Flowable :: (Typeable a, FlowTyped a) => Proxy a -> Flowable+ 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)@@ -143,53 +221,120 @@ instance Eq Flowable where Flowable a == Flowable b = typeRep a == typeRep b --- | The main AST for flowtypes.+instance Ord Flowable where+ Flowable a `compare` Flowable b = typeRep a `compare` typeRep b -data FlowTypeF a- = Object !(HashMap Text a)- | ExactObject !(HashMap Text a)- | ObjectMap !Text a- | Array a- | Tuple !(Vector a)- | Fun !(Vector (Text, a)) a- | Alt a a- | Prim !PrimType- | Nullable a- | Omitable a- | Literal !A.Value- | Tag !Text- | Name !FlowName- | Instantiate !TypeRep a- | PolyVar !TypeRep- | PolyUse !Flowable- | PolyApply a [a]- deriving (Show, Eq, Functor, Traversable, Foldable)--- XXX: vector >= 0.12 has Eq1 vector which allows us to use eq for Fix FlowTypeF--- and related types+-- 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 Info a = Constr !Text FlowTypeI a | NoInfo a+data GFlowInfo a = Constr !Text GFlowTypeI a | NoInfo a deriving (Show, Functor, Traversable, Foldable) -instance Show1 (Showy Info) where+instance Show1 (Showy GFlowInfo) where liftShowsPrec _ _ i (Showy a) = showsPrec i a -instance Show1 Info where+instance Show1 GFlowInfo where liftShowsPrec sp sl i a = liftShowsPrec sp sl i (reify sp (\p -> Showy (fmap (inj p) a))) -type FlowTypeI = Fix (Info `Compose` FlowTypeF)+type GFlowTypeI = Fix (GFlowInfo `Compose` FlowTypeF) type FlowType = Fix FlowTypeF text :: Text -> PP.Doc text = PP.text . T.unpack -type Poly = State (Map TypeRep Text)+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@@ -216,7 +361,7 @@ ppJson :: A.Value -> PP.Doc ppJson v = case v of A.Array a -> PP.list (map ppJson (V.toList a))- A.String t -> PP.squotes (text t)+ 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"@@ -241,205 +386,289 @@ 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' -getVar :: TypeRep -> Poly Text-getVar rep = do- s <- get- case M.lookup rep s of- Just i -> return i- Nothing -> do- let r = polyVarNames !! M.size s- r <$ modify' (M.insert rep r)- 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 :: FlowType -> Poly PP.Doc pp (Fix ft) = case ft of- ObjectMap keyName a ->+ 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 -> braceBarList <$> ppObject hm- Array a -> (\r -> mayWrap a r PP.<> PP.string "[]") <$> pp a- Tuple t -> PP.list <$> mapM pp (V.toList t)- Alt a b -> ppAlts [a] b- Prim pt -> return $ case pt of- Boolean -> PP.text "boolean"- Number -> PP.text "number"- String -> PP.text "string"- Void -> PP.text "void"- Any -> PP.text "any"- Mixed -> PP.text "mixed"- Nullable a -> (\r -> PP.char '?' PP.<> mayWrap a r) <$> pp a- Omitable a -> (\r -> PP.char '?' PP.<> mayWrap a r) <$> pp a -- hopefully these are caught- Literal a -> return (ppJson a)- Tag t -> return (PP.squotes (text t))- Name (FlowName _ t) -> return (text t)- PolyVar rep -> text <$> getVar rep- PolyUse (Flowable fp) -> pp (flowType fp)- PolyApply a vars -> do- n <- pp a- vs <- mapM pp vars- return (n PP.<> PP.angles (PP.hsep (PP.punctuate PP.comma vs)))- _ -> return (PP.string (show ft)) + 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-showFlowType :: FlowType -> Text-showFlowType ft = T.pack (show (evalState (pp ft) M.empty))+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.-exportFlowTypeAs :: Text -> FlowType -> Text-exportFlowTypeAs = flowTypeAs True+exportTypeAs :: RenderOptions -> Text -> FlowType -> [Flowable] -> Text+exportTypeAs opts = showTypeAs opts True --- | Generate a @ export type @ declaration.-flowTypeAs :: Bool -> Text -> FlowType -> Text-flowTypeAs isExport name ft =+-- | 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.<>- PP.string (T.unpack name) PP.<> withVars (runState (pp ft) M.empty)+ 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- main r = PP.string "=" PP.<$> PP.indent 2 r PP.<> PP.string ";"- withVars (r, vars)- | M.null vars = PP.space PP.<> main r- | otherwise = PP.angles (PP.hsep- (PP.punctuate PP.comma (map text (M.elems vars))))- PP.<+>- main r+ 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 :: (Typeable a, FlowTyped a) => Proxy a -> Set.Set FlowName-dependencies p0 = M.foldlWithKey'- (\acc k a -> Set.insert k (Set.union a acc))- Set.empty- (go p0 M.empty)+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- -- XXX: catch mutual recursion- addImmediateDeps :: FlowName- -> Map FlowName (Set.Set FlowName)- -> Map FlowName (Set.Set FlowName)- addImmediateDeps fn@(FlowName p _) acc0 =- foldr- (\(FlowName p _) -> go p)- (M.insert fn sub acc0)- sub- where sub = immediateDeps (flowType p)+ flowNameToFlowable (FlowName fn _) = Flowable fn - go :: (FlowTyped a, Typeable a)- => Proxy a- -> Map FlowName (Set.Set FlowName)- -> Map FlowName (Set.Set FlowName)- go p acc =- case FlowName p <$> flowTypeName p of- Just fn | fn `M.notMember` acc -> addImmediateDeps fn acc- _ -> acc+ immediateDeps :: FlowType -> Set.Set FlowName+ immediateDeps (FCallType n tys) = Set.insert n (Set.unions (map immediateDeps tys))+ immediateDeps (Fix p) = foldMap immediateDeps p -immediateDeps :: FlowType -> Set.Set FlowName-immediateDeps (Fix (Name n)) = Set.singleton n-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 FlowModuleOptions = FlowModuleOptions+data ModuleOptions = ModuleOptions { -- | You might want to change this to include e.g. flow-runtime- flowPragmas :: [Text]- , flowHeader :: [Text]- , flowExportDeps :: Bool- , flowComputeDeps :: Bool+ pragmas :: [Text]+ , header :: [Text]+ , exportDeps :: Bool+ , computeDeps :: Bool+ , renderOptions :: RenderOptions } deriving (Eq, Show) -defaultFlowModuleOptions :: FlowModuleOptions-defaultFlowModuleOptions = FlowModuleOptions- { flowPragmas = ["// @flow"]- , flowHeader = ["This module has been generated by aeson-flowtyped."]- , flowExportDeps = True- , flowComputeDeps = True+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 :: (Typeable a, FlowTyped a)- => Proxy a- -> Export+ 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 (\(Export a) -> dependencies a)+exportsDependencies = foldMap $ \e -> case e of+ Export a -> dependencies a -generateFlowModule :: FlowModuleOptions -> [Export] -> Text-generateFlowModule opts exports =- T.unlines- . (\m ->- (flowPragmas opts ++ map ("// " `T.append`) (flowHeader opts)) ++- (T.empty : m))+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 flowComputeDeps opts+ if computeDeps opts then Set.toList . exportsDependencies- else catMaybes . map (\(Export p) -> FlowName p <$> flowTypeName p)+ else catMaybes . map (\ex -> case ex of+ Export p -> FlowName p <$> flowTypeName p) flowDecl (FlowName p name) =- if Export p `elem` exports || flowExportDeps opts- then flowTypeAs True name (flowType p)- else flowTypeAs False name (flowType p)+ 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) -writeFlowModule :: FlowModuleOptions -> FilePath -> [Export] -> IO ()-writeFlowModule opts path =- TIO.writeFile path . generateFlowModule opts+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 = gflowType opt (fmap from p)+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 (T.pack (symbolVal (pGetName (fmap from p))))+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 -flowTypePreferName :: (Typeable a, FlowTyped a) => Proxy a -> FlowType-flowTypePreferName p = fromMaybe (flowType p) (flowTypeRecur p)+ 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 -flowTypeRecur :: (Typeable a, FlowTyped a) => Proxy a -> Maybe FlowType-flowTypeRecur p = case flowTypeName p of- Just n- | null vars -> Just name- | otherwise -> Just (Fix (PolyApply name (map doPoly vars)))- where- doPoly :: TypeRep -> FlowType- doPoly = Fix . PolyVar - vars = flowTypeVars p- name = Fix (Name (FlowName p n))- Nothing -> Nothing+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 -> [TypeRep]+ flowTypeVars :: Proxy a -> [Flowable] flowTypeVars _ = [] flowOptions :: Proxy a -> Options@@ -457,35 +686,95 @@ -> 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) -> FlowTypeI+ gflowVal :: Options -> Proxy (g x) -> GFlowTypeI instance (KnownSymbol name, GFlowVal c) => GFlowTyped (D1 ('MetaData name mod pkg t) c) where- gflowType opt _ = runFlowI (checkNullary (gflowVal opt (Proxy :: Proxy (c x))))+ gflowType opt _ = runFlowI (postprocess (gflowVal opt (Proxy :: Proxy (c x)))) where- checkNullary :: FlowTypeI -> FlowTypeI- checkNullary i+ 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- -- single-constructor data types have a "contents" field of Prim Void- isNullary :: FlowTypeI -> Bool- isNullary (FC (Info (Prim Void))) = True- isNullary _ = False+#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] -> FlowTypeI -> Maybe [Text]+ 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@@ -505,7 +794,7 @@ go _ _ = Nothing - runFlowI :: FlowTypeI -> FlowType+ runFlowI :: GFlowTypeI -> FlowType runFlowI = cata $ \(Compose i) -> case i of Constr _name _t a -> Fix a NoInfo a -> Fix a@@ -526,17 +815,17 @@ gfieldName opt _ = T.pack (fieldLabelModifier opt (symbolVal (Proxy :: Proxy name))) -noInfo :: f (Fix (Compose Info f)) -> Fix (Compose Info f)+noInfo :: f (Fix (Compose GFlowInfo f)) -> Fix (Compose GFlowInfo f) noInfo = Fix . Compose . NoInfo -infoConstr :: Text -> FlowTypeI -> f (Fix (Compose Info f)) -> Fix (Compose Info f)+infoConstr :: Text -> GFlowTypeI -> f (Fix (Compose GFlowInfo f)) -> Fix (Compose GFlowInfo f) infoConstr tag nxt = Fix . Compose . Constr tag nxt -discardInfo :: Info a -> a+discardInfo :: GFlowInfo a -> a discardInfo (NoInfo a) = a discardInfo (Constr _ _ a) = a -pattern Info :: a -> Info a+pattern Info :: a -> GFlowInfo a pattern Info a <- (discardInfo -> a) where Info = NoInfo @@ -545,20 +834,22 @@ instance (KnownSymbol conName, GFlowRecord r) => GFlowVal (C1 ('MetaCons conName fx 'True) r) where- gflowVal opt p = 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)])+ 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 $ \(Fix t) -> Fix $ case t of- Nullable a -> Omitable a+ then H.map $ \t -> case t of+ FNullable a -> FOmitable a _ -> t- else id+ else traceShow opt id next = H.map@@ -584,8 +875,9 @@ instance GFlowVal f => GFlowVal (M1 i ('MetaSel mj du ds dl) f) where gflowVal opt p = gflowVal opt (fmap unM1 p) -instance (Typeable r, FlowTyped r) => GFlowVal (Rec0 r) where- gflowVal _opt p = cata noInfo (flowTypePreferName (fmap unK1 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@@ -605,7 +897,7 @@ b@(Fix (Compose (Info fB))) = gflowVal opt (Proxy :: Proxy (b x)) instance GFlowVal U1 where- gflowVal _ _ = noInfo (Prim Void)+ gflowVal _ _ = noInfo (Prim Undefined) class GFlowRecord a where gflowRecordFields :: Options -> Proxy (a x) -> HashMap Text FlowType@@ -631,161 +923,197 @@ -------------------------------------------------------------------------------- -- Instances -instance (Typeable a, FlowTyped a) => FlowTyped [a] where- flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))+instance (FlowCallable a) => FlowTyped [a] where+ flowType _ = FArray (callType (Proxy :: Proxy a)) isPrim _ = True flowTypeName _ = Nothing -instance (FlowTyped a, Typeable a) => FlowTyped (Vector a) where- flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))+instance (FlowCallable a) => FlowTyped (Vector a) where+ flowType _ = FArray (callType (Proxy :: Proxy a)) isPrim _ = True flowTypeName _ = Nothing -instance (FlowTyped a, Typeable a) => FlowTyped (VU.Vector a) where- flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))+instance (FlowCallable a) => FlowTyped (VU.Vector a) where+ flowType _ = FArray (callType (Proxy :: Proxy a)) isPrim _ = True flowTypeName _ = Nothing -instance (FlowTyped a, Typeable a) => FlowTyped (VS.Vector a) where- flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))+instance (FlowCallable a) => FlowTyped (VS.Vector a) where+ flowType _ = FArray (callType (Proxy :: Proxy a)) isPrim _ = True flowTypeName _ = Nothing -instance ( FlowTyped a, Typeable a- , FlowTyped b, Typeable b) => FlowTyped (a, b) where+instance ( FlowCallable a+ , FlowCallable b+ ) => FlowTyped (a, b) where flowTypeName _ = Nothing flowType _ =- Fix (Tuple (V.fromList [aFt, bFt]))+ FTuple (V.fromList [aFt, bFt]) where- aFt = flowTypePreferName (Proxy :: Proxy a)- bFt = flowTypePreferName (Proxy :: Proxy b)+ aFt = callType (Proxy :: Proxy a)+ bFt = callType (Proxy :: Proxy b) -instance (FlowTyped a, Typeable a) => FlowTyped (Maybe a) where- flowType _ = Fix (Nullable (flowTypePreferName (Proxy :: Proxy a)))+instance (FlowCallable a) => FlowTyped (Maybe a) where+ flowType _ = FNullable (callType (Proxy :: Proxy a)) isPrim _ = True flowTypeName _ = Nothing -instance ( FlowTyped a, Typeable a- , FlowTyped b, Typeable b) =>+instance ( FlowCallable a+ , FlowCallable b) => FlowTyped (Either a b) where flowTypeName _ = Nothing- flowType _ = Fix- (Alt- (Fix (ExactObject (H.fromList [("Left", aFt)])))- (Fix (ExactObject (H.fromList [("Right", bFt)]))))+ flowType _ = FAlt+ (FExactObject (H.fromList [("Left", aFt)]))+ (FExactObject (H.fromList [("Right", bFt)])) where- aFt = flowTypePreferName (Proxy :: Proxy a)- bFt = flowTypePreferName (Proxy :: Proxy b)+ aFt = callType (Proxy :: Proxy a)+ bFt = callType (Proxy :: Proxy b) -instance ( FlowTyped a, Typeable a- , FlowTyped b, Typeable b- , FlowTyped c, Typeable c) =>+instance ( FlowCallable a+ , FlowCallable b+ , FlowCallable c) => FlowTyped (a, b, c) where flowTypeName _ = Nothing- flowType _ = Fix (Tuple (V.fromList [aFt, bFt, cFt]))+ flowType _ = FTuple (V.fromList [aFt, bFt, cFt]) where- aFt = flowTypePreferName (Proxy :: Proxy a)- bFt = flowTypePreferName (Proxy :: Proxy b)- cFt = flowTypePreferName (Proxy :: Proxy c)+ 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 _ = Fix (Prim String)+ flowType _ = FPrimString flowTypeName _ = Nothing instance FlowTyped TL.Text where isPrim _ = True- flowType _ = Fix (Prim String)+ flowType _ = FPrimString flowTypeName _ = Nothing instance {-# OVERLAPS #-} FlowTyped String where isPrim _ = True- flowType _ = Fix (Prim String)+ flowType _ = FPrimString flowTypeName _ = Nothing instance FlowTyped Void.Void where isPrim _ = True- flowType _ = Fix (Prim Void)+ flowType _ = FPrimBottom flowTypeName _ = Nothing instance FlowTyped Char where isPrim _ = True- flowType _ = Fix (Prim String)+ flowType _ = FPrimString flowTypeName _ = Nothing instance FlowTyped Bool where isPrim _ = True- flowType _ = Fix (Prim Boolean)+ flowType _ = FPrimBoolean flowTypeName _ = Nothing instance FlowTyped A.Value where isPrim _ = True- flowType _ = Fix (Prim Mixed)+ flowType _ = FPrimMixed flowTypeName _ = Nothing instance FlowTyped UTCTime where isPrim _ = False- flowType _ = Fix (Prim String)+ flowType _ = FPrimString flowTypeName _ = Nothing instance Typeable a => FlowTyped (Fixed a) where isPrim _ = False- flowType _ = Fix (Prim Number)+ flowType _ = FPrimNumber flowTypeName _ = Nothing --- | This is at odds with "aeson" which defines 'A.ToJSONKey'-instance (Typeable a, FlowTyped a) => FlowTyped (HashMap Text a) where+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 _ = Fix (ObjectMap "key" (flowTypePreferName (Proxy :: Proxy a)))- flowTypeName _ = Nothing -instance (Typeable a, FlowTyped a) => FlowTyped (Set.Set a) where+ 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 _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))+ flowType _ = FArray (callType (Proxy :: Proxy a)) flowTypeName _ = Nothing instance FlowTyped IntSet.IntSet where isPrim _ = False- flowType _ = Fix (Array (Fix (Prim Number)))+ flowType _ = FArray FPrimNumber -- (Fix (Prim Number)) flowTypeName _ = Nothing -instance (Typeable a, FlowTyped a) => FlowTyped (I.IntMap a) where+instance (FlowCallable a) => FlowTyped (I.IntMap a) where isPrim _ = False flowType _ = Fix . Array . Fix . Tuple . V.fromListN 2 $- [ flowType (Proxy :: Proxy Int)- , flowType (Proxy :: Proxy a)+ [ FPrimNumber+ , callType (Proxy :: Proxy a) ] flowTypeName _ = Nothing -instance (Typeable a, FlowTyped a) => FlowTyped (HashSet.HashSet a) where- isPrim _ = False- flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a)))- flowTypeName _ = Nothing--data Var :: k -> Type where Var :: Var a--instance (Typeable a, Typeable k) => FlowTyped (Var (a :: k)) where+instance (FlowCallable a) => FlowTyped (HashSet.HashSet a) where isPrim _ = False- flowType _ = Fix (PolyVar (typeOf (Var :: Var a)))+ 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, Typeable a) => FlowTyped (Tree.Tree a) where+instance (FlowCallable a) => FlowTyped (Tree.Tree a) where isPrim _ = False- flowType _ = Fix (Tuple- (V.fromList- [ Fix (PolyUse (Flowable (Proxy :: Proxy a)))- , Fix (Array- (fromJust (flowTypeRecur (Proxy :: Proxy (Tree.Tree a)))))- ]))+ flowType _ = FTuple+ (V.fromList+ [ FGenericParam 0+ , FArray (callType' (Proxy :: Proxy (Tree.Tree a)) [FGenericParam 0])+ ]) flowTypeName _ = Just "Tree"- flowTypeVars _ = [typeRep (Var :: Var a)]+ flowTypeVars _ = [Flowable (Proxy :: Proxy a)] instance FlowTyped () where isPrim _ = False- flowType _ = Fix (Tuple V.empty)+ flowType _ = FTuple V.empty flowTypeName _ = Nothing -- monomorphic numeric instances@@ -794,10 +1122,11 @@ [d| instance FlowTyped $ty where isPrim _ = False- flowType _ = Fix (Prim Number)+ 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
test/Spec.hs view
@@ -5,8 +5,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Data.Aeson (Value)-import Data.Aeson.Flow-import Data.Functor.Foldable (Fix (..))+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)@@ -16,6 +17,10 @@ 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@@ -77,29 +82,28 @@ main = defaultMain $ testGroup "aeson-flowtyped" [ testCase "nullable" $ showFlowType (flowType (Proxy :: Proxy (Maybe Int))) @=?- showFlowType (Fix (Nullable (Fix (Prim Number))))+ showFlowType (FNullable FPrimNumber) , testCase "array" $ do showFlowType (flowType (Proxy :: Proxy [Int])) @=?- showFlowType (Fix (Array (Fix (Prim Number))))+ showFlowType (FArray FPrimNumber) showFlowType (flowType (Proxy :: Proxy (Vector Int))) @=?- showFlowType (Fix (Array (Fix (Prim Number))))+ showFlowType (FArray FPrimNumber) -- (Fix (Array (Fix (Prim Number)))) -- XXX: actually use Eq , testCase "User export" $ "export type User =\n\ \ {| extraInfo: mixed,\n\- \ tag: 'User',\n\- \ realname: ?string,\n\+ \ dob: null | [number,number,number],\n\ \ username: string,\n\- \ dob: ?[number,number,number] |};" @=?+ \ realname: null | string |};" @=? exportFlowTypeAs "User" (flowType (Proxy :: Proxy User)) , testCase "Recursive type export" $ "export type Recur =\n\- \ {| tag: 'Recur', stuff: User[], recurs: Recur[], asdf: number |};" @=?+ \ {| stuff: User[], recurs: Recur[], asdf: number |};" @=? exportFlowTypeAs "Recur" (flowType (Proxy :: Proxy Recur)) , testCase "Nullary string tags (2 tags)" $@@ -130,12 +134,12 @@ , testCase "parens around nullable array" $ "export type T =\n\- \ ?(string[]);" @=?+ \ null | string[];" @=? exportFlowTypeAs "T" (flowType (Proxy :: Proxy (Maybe [Text]))) , testCase "parens around nullable array of nullable elements" $ "export type T =\n\- \ ?((?string)[]);" @=?+ \ null | (null | string)[];" @=? exportFlowTypeAs "T" (flowType (Proxy :: Proxy (Maybe [Maybe Text]))) , testCase "export dependencies" $@@ -154,19 +158,21 @@ \// This module has been generated by aeson-flowtyped.\n\n\ \export type Tree<A> =\n\ \ [A,Tree<A>[]];\n" @=?- generateFlowModule defaultFlowModuleOptions+ generateModule flowModuleOptions [ Export (Proxy :: Proxy (Tree (Var 0))) ] + {- , testCase "polymorphism (arity 2)" $ "// @flow\n\ \// This module has been generated by aeson-flowtyped.\n\n\ \export type Poly2<A, B> =\n\ \ {| tag: 'Poly2', contents: [A,B] |} |\n\ \ {| tag: 'Poly2Go', contents: Poly2<A, B> |};\n" @=?- generateFlowModule defaultFlowModuleOptions+ generateModule flowModuleOptions [ Export (Proxy :: Proxy (Poly2 (Var 0) (Var 1))) ]+ -} , testCase "monomorphic use of polymorphic type (dependencies)" $ [ FlowName (Proxy :: Proxy Mono) "Mono"@@ -174,12 +180,15 @@ ] @=? exportsDependencies [Export (Proxy :: Proxy Mono)] + {- , testCase "monomorphic use of polymorphic type" $ "// @flow\n\ \// This module has been generated by aeson-flowtyped.\n\n\ \export type Poly2<A, B> =\n\ \ {| tag: 'Poly2', contents: [A,B] |} |\n\ \ {| tag: 'Poly2Go', contents: Poly2<A, B> |};\n" @=?- generateFlowModule defaultFlowModuleOptions [Export (Proxy :: Proxy Mono)]+ generateModule flowModuleOptions+ [Export (Proxy :: Proxy Mono)]+ -} ]