diff --git a/aeson-flowtyped.cabal b/aeson-flowtyped.cabal --- a/aeson-flowtyped.cabal +++ b/aeson-flowtyped.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: aeson-flowtyped -version: 0.8.1 +version: 0.9.0 synopsis: Create Flow type definitions from Haskell data types. description: Create Flow type definitions from Haskell data types. category: Web 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 @@ -35,9 +35,11 @@ , generateFlowModule , writeFlowModule , exportFlowTypeAs + , flowTypeAs -- * Utility functions , showFlowType , dependencies + , exportsDependencies -- * Internals , defaultFlowType , defaultFlowTypeName @@ -86,6 +88,7 @@ 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 @@ -285,9 +288,13 @@ -- | Generate a @ export type @ declaration. exportFlowTypeAs :: Text -> FlowType -> Text -exportFlowTypeAs name ft = +exportFlowTypeAs = flowTypeAs True + +-- | Generate a @ export type @ declaration. +flowTypeAs :: Bool -> Text -> FlowType -> Text +flowTypeAs isExport name ft = T.pack . render $ - PP.string "export type " PP.<> + PP.string (if isExport then "export type " else "type ") PP.<> PP.string (T.unpack name) PP.<> withVars (runState (pp ft) M.empty) where main r = PP.string "=" PP.<$> PP.indent 2 r PP.<> PP.string ";" @@ -297,57 +304,87 @@ (PP.punctuate PP.comma (map text (M.elems vars)))) PP.<+> main r - 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 = subDeps (immediateDeps (flowType p0) Set.empty) +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) where - this :: Set.Set FlowName - this = foldMap Set.singleton (FlowName p0 <$> flowTypeName p0) - - subDeps :: Set.Set FlowName -> Set.Set FlowName - subDeps = + -- XXX: catch mutual recursion + addImmediateDeps :: FlowName + -> Map FlowName (Set.Set FlowName) + -> Map FlowName (Set.Set FlowName) + addImmediateDeps fn@(FlowName p _) acc0 = foldr - (\fn@(FlowName p _) acc -> - if Set.member fn acc - then acc - else dependencies p `Set.union` acc) - this + (\(FlowName p _) -> go p) + (M.insert fn sub acc0) + sub + where sub = immediateDeps (flowType p) - immediateDeps :: FlowType -> Set.Set FlowName -> Set.Set FlowName - immediateDeps (Fix (Name n)) acc = Set.insert n acc - immediateDeps (Fix p) acc = foldr' immediateDeps acc p + 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 (Fix (Name n)) = Set.singleton n +immediateDeps (Fix p) = foldMap immediateDeps p + data FlowModuleOptions = FlowModuleOptions { -- | You might want to change this to include e.g. flow-runtime - flowPragmas :: [Text] - , flowHeader :: [Text] + flowPragmas :: [Text] + , flowHeader :: [Text] + , flowExportDeps :: Bool + , flowComputeDeps :: Bool } deriving (Eq, Show) defaultFlowModuleOptions :: FlowModuleOptions defaultFlowModuleOptions = FlowModuleOptions { flowPragmas = ["// @flow"] , flowHeader = ["This module has been generated by aeson-flowtyped."] + , flowExportDeps = True + , flowComputeDeps = True } data Export where - Export :: FlowTyped a => Proxy a -> Export + Export :: (Typeable a, FlowTyped a) => Proxy a -> Export +instance Eq Export where + Export p0 == Export p1 = typeRep p0 == typeRep p1 + +exportsDependencies :: [Export] -> Set.Set FlowName +exportsDependencies = foldMap (\(Export a) -> dependencies a) + generateFlowModule :: FlowModuleOptions -> [Export] -> Text -generateFlowModule opts = +generateFlowModule opts exports = T.unlines . (\m -> (flowPragmas opts ++ map ("// " `T.append`) (flowHeader opts)) ++ (T.empty : m)) - . foldr addExport [] - . Set.unions - . map (\(Export a) -> dependencies a) + . map flowDecl + . flowNames + $ exports where - addExport (FlowName p name) acc = - exportFlowTypeAs name (flowType p):acc + flowNames = + if flowComputeDeps opts + then Set.toList . exportsDependencies + else catMaybes . map (\(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) + writeFlowModule :: FlowModuleOptions -> FilePath -> [Export] -> IO () writeFlowModule opts path = TIO.writeFile path . generateFlowModule opts @@ -381,7 +418,7 @@ name = Fix (Name (FlowName p n)) Nothing -> Nothing -class Typeable a => FlowTyped a where +class FlowTyped a where flowType :: Proxy a -> FlowType flowTypeName :: Proxy a -> Maybe Text @@ -530,7 +567,7 @@ instance GFlowVal f => GFlowVal (M1 i ('MetaSel mj du ds dl) f) where gflowVal opt p = gflowVal opt (fmap unM1 p) -instance FlowTyped r => GFlowVal (Rec0 r) where +instance (Typeable r, FlowTyped r) => GFlowVal (Rec0 r) where gflowVal _opt p = cata noInfo (flowTypePreferName (fmap unK1 p)) instance (GFlowVal a, GFlowVal b) => GFlowVal (a :+: b) where @@ -577,27 +614,28 @@ -------------------------------------------------------------------------------- -- Instances -instance FlowTyped a => FlowTyped [a] where +instance (Typeable a, FlowTyped a) => FlowTyped [a] where flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a))) isPrim _ = True flowTypeName _ = Nothing -instance FlowTyped a => FlowTyped (Vector a) where +instance (FlowTyped a, Typeable a) => FlowTyped (Vector a) where flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a))) isPrim _ = True flowTypeName _ = Nothing -instance FlowTyped a => FlowTyped (VU.Vector a) where +instance (FlowTyped a, Typeable a) => FlowTyped (VU.Vector a) where flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a))) isPrim _ = True flowTypeName _ = Nothing -instance FlowTyped a => FlowTyped (VS.Vector a) where +instance (FlowTyped a, Typeable a) => FlowTyped (VS.Vector a) where flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a))) isPrim _ = True flowTypeName _ = Nothing -instance (FlowTyped a, FlowTyped b) => FlowTyped (a, b) where +instance ( FlowTyped a, Typeable a + , FlowTyped b, Typeable b) => FlowTyped (a, b) where flowTypeName _ = Nothing flowType _ = Fix (Tuple (V.fromList [aFt, bFt])) @@ -605,12 +643,14 @@ aFt = flowTypePreferName (Proxy :: Proxy a) bFt = flowTypePreferName (Proxy :: Proxy b) -instance FlowTyped a => FlowTyped (Maybe a) where +instance (FlowTyped a, Typeable a) => FlowTyped (Maybe a) where flowType _ = Fix (Nullable (flowTypePreferName (Proxy :: Proxy a))) isPrim _ = True flowTypeName _ = Nothing -instance (FlowTyped a, FlowTyped b) => FlowTyped (Either a b) where +instance ( FlowTyped a, Typeable a + , FlowTyped b, Typeable b) => + FlowTyped (Either a b) where flowTypeName _ = Nothing flowType _ = Fix (Alt @@ -620,10 +660,10 @@ aFt = flowTypePreferName (Proxy :: Proxy a) bFt = flowTypePreferName (Proxy :: Proxy b) -instance ( FlowTyped a - , FlowTyped b - , FlowTyped c - ) => FlowTyped (a, b, c) where +instance ( FlowTyped a, Typeable a + , FlowTyped b, Typeable b + , FlowTyped c, Typeable c) => + FlowTyped (a, b, c) where flowTypeName _ = Nothing flowType _ = Fix (Tuple (V.fromList [aFt, bFt, cFt])) where @@ -677,13 +717,13 @@ flowTypeName _ = Nothing -- | This is at odds with "aeson" which defines 'A.ToJSONKey' -instance FlowTyped a => FlowTyped (HashMap Text a) where +instance (Typeable a, FlowTyped a) => FlowTyped (HashMap Text 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 FlowTyped a => FlowTyped (Set.Set a) where +instance (Typeable a, FlowTyped a) => FlowTyped (Set.Set a) where isPrim _ = False flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a))) flowTypeName _ = Nothing @@ -693,7 +733,7 @@ flowType _ = Fix (Array (Fix (Prim Number))) flowTypeName _ = Nothing -instance FlowTyped a => FlowTyped (HashSet.HashSet a) where +instance (Typeable a, FlowTyped a) => FlowTyped (HashSet.HashSet a) where isPrim _ = False flowType _ = Fix (Array (flowTypePreferName (Proxy :: Proxy a))) flowTypeName _ = Nothing diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Data.Aeson (Value) @@ -41,9 +42,13 @@ data Adt4 = A4 | B4 | C4 | D4 deriving (Generic) instance FlowTyped Adt4 +data Sub = Sub Adt4 deriving (Generic) +instance FlowTyped Sub + data Codep = Codep { corecurs :: [Recur] , cousers :: [User] + , subsub :: Sub } deriving (Generic) instance FlowTyped Codep @@ -128,20 +133,14 @@ \ ?((?string)[]);" @=? exportFlowTypeAs "T" (flowType (Proxy :: Proxy (Maybe [Maybe Text]))) - , testCase "module export" $ - "// @flow\n\ - \// This module has been generated by aeson-flowtyped.\n\n\ - \export type Codep =\n\ - \ {| corecurs: Recur[], tag: 'Codep', cousers: User[] |};\n\ - \export type User =\n\ - \ {| extraInfo: mixed,\n\ - \ tag: 'User',\n\ - \ realname: ?string,\n\ - \ username: string,\n\ - \ dob: ?[number,number,number] |};\n\ - \export type Recur =\n\ - \ {| tag: 'Recur', stuff: User[], recurs: Recur[], asdf: number |};\n" @=? - generateFlowModule defaultFlowModuleOptions + , testCase "export dependencies" $ + [ FlowName (Proxy :: Proxy Codep) "Codep" + , FlowName (Proxy :: Proxy User) "User" + , FlowName (Proxy :: Proxy Recur) "Recur" + , FlowName (Proxy :: Proxy Sub) "Sub" + , FlowName (Proxy :: Proxy Adt4) "Adt4" + ] @=? + exportsDependencies [ Export (Proxy :: Proxy Codep) ]