367aefd · gogol · git.iko.soy

git.iko.soy/gogol

Initial dummy prefixing and sum type rendering

commit367aefdf7be34f80e4cad58ccc2554efa9bc9654 authorBrendan Hay <brendan.g.hay@gmail.com> dateFri 25 Sep 2015, 11:17 (11 years ago) parentf9920b0

7 files changed+296−75

compare with develop

unifiedsplit

gen/src/Gen/AST.hs+22−16 gen/src/Gen/Orphans.hs+34 gen/src/Gen/Prefix.hs+146 gen/src/Gen/Solve.hs+32−6 gen/src/Gen/Syntax.hs+25−34 gen/src/Gen/Types.hs+13−9 gen/src/Gen/Types/Id.hs+24−10

gen/src/Gen/AST.hs+22−16

@@ -1,5 +1,4 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TupleSections #-}

32{-# LANGUAGE DeriveGeneric #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

@@ -10,6 +9,7 @@

109{-# LANGUAGE RankNTypes #-}

1110{-# LANGUAGE RecordWildCards #-}

1211{-# LANGUAGE TemplateHaskell #-}

12+{-# LANGUAGE TupleSections #-}

1313{-# LANGUAGE ViewPatterns #-}

1414

1515-- Module : Gen.AST

@@ -21,6 +21,7 @@

2121

2222module Gen.AST where

2323

24+import Data.Bifunctor

2425import Control.Applicative

2526import Control.Error

2627import Control.Lens hiding (lens)

@@ -60,25 +61,30 @@ render svc = do

6061 Ref {} -> pure Nothing

6162 Any {} -> pure Nothing

6263 Lit {} -> pure Nothing

63− Enum i _ _ -> Just <$> sum

64+ Enum i vs ds -> do

65+ n <- _prefix <$> solve k

66+ return (Just (sum n))

6467 where

65− sum = Sum (dname k) (i ^. description)

66− <$> pp Indent enumDecl

68+ sum n = Sum (dname n) (i ^. description)

69+ (Map.fromList $ map (first (dname . Pre . idFromText) . join (,)) vs)

70+ (map rawHelpText ds)

6771

68− Obj i rs -> Just <$> (traverse solve rs >>= prod)

72+ Obj i rs -> do

73+ n <- _prefix <$> solve k

74+ Just <$> (traverse solve rs >>= prod n)

6975 where

70− prod ts = Prod (dname k) (i ^. description)

71− <$> (objDecl k ts >>= pp Indent)

72− <*> ctor ts

73− <*> traverse (uncurry lens) (Map.toList ts)

76+ prod n ts = Prod (dname n) (i ^. description)

77+ <$> (objDecl k n ts >>= pp Indent)

78+ <*> ctor n ts

79+ <*> traverse (lens n) (Map.elems ts)

7480

75− ctor ts = Fun' (cname k) (Just help)

76− <$> (pp None (ctorSig k ts) >>= comments ts)

77− <*> pp Indent (ctorDecl k ts)

81+ ctor n ts = Fun' (cname n) (Just help)

82+ <$> (pp None (ctorSig n ts) >>= comments ts)

83+ <*> pp Indent (ctorDecl n ts)

7884

79− lens n v = Fun' (lname n) (v ^. description)

80− <$> pp None (lensSig k n v)

81− <*> pp Print (lensDecl n v)

85+ lens n v = Fun' (lname (_prefix v)) (v ^. description)

86+ <$> pp None (lensSig n v)

87+ <*> pp Print (lensDecl n v)

8288

8389 help = rawHelpText $

8490 sformat ("Creates a value of '" % fid %

@@ -109,7 +115,7 @@ flatten svc = svc

109115

110116 Enum i vs ds -> res (Enum i vs ds)

111117 Lit i l -> res (Lit i l)

112− Ref _ r -> pure r

118+ Ref i r -> res (Ref i r)

113119 Any i -> res (Any i)

114120

115121 where

gen/src/Gen/Orphans.hsnew file+34

@@ -0,0 +1,34 @@

1+{-# LANGUAGE FlexibleInstances #-}

3+{-# OPTIONS_GHC -fno-warn-orphans #-}

5+-- Module : Gen.Orphans

7+-- License : Mozilla Public License, v. 2.0.

8+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>

9+-- Stability : provisional

10+-- Portability : non-portable (GHC extensions)

11+

12+module Gen.Orphans where

13+

14+import Data.Aeson

15+import Data.Bifunctor

16+import Data.Hashable

17+import qualified Data.HashMap.Strict as Map

18+import Data.String

19+import qualified Data.Text as Text

20+import Language.Haskell.Exts.Build

21+import Language.Haskell.Exts.Pretty

22+import Language.Haskell.Exts.Syntax

23+

24+instance Hashable Name

25+

26+instance IsString Name where fromString = name

27+instance IsString QName where fromString = UnQual . name

28+instance IsString QOp where fromString = op . sym

29+

30+instance ToJSON a => ToJSON (Map.HashMap Name a) where

31+ toJSON = toJSON

32+ . Map.fromList

33+ . map (first (Text.pack . prettyPrint))

34+ . Map.toList

gen/src/Gen/Prefix.hsnew file+146

@@ -0,0 +1,146 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TypeOperators #-}

8+-- Module : Gen.Prefix

10+-- License : Mozilla Public License, v. 2.0.

11+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>

12+-- Stability : provisional

13+-- Portability : non-portable (GHC extensions)

14+

15+module Gen.Prefix where

16+

17+-- type Seen = Map (CI Text) (Set (CI Text))

18+

19+-- data Env = Env

20+-- { _memo :: Map Id (Maybe Text)

21+-- , _branches :: Seen

22+-- , _fields :: Seen

23+-- }

24+

25+-- makeLenses ''Env

26+

27+-- type MemoP = StateT Env (Either Error)

28+

29+-- prefixes :: Map Id (Shape Related) -> Either Error (Map Id (Shape Prefixed))

30+-- prefixes ss = evalStateT (traverse assignPrefix ss) env

31+-- where

32+-- env = Env mempty mempty (smartCtors ss)

33+

34+-- -- | Record projected smart constructors in set of seen field names.

35+-- smartCtors :: Map Id (Shape a) -> Seen

36+-- smartCtors = Map.fromListWith (<>) . mapMaybe go . Map.toList

37+-- where

38+-- go :: (Id, Shape a) -> Maybe (CI Text, Set (CI Text))

39+-- go (s, _ :< Struct {}) = Just (k, Set.singleton v)

40+-- where

41+-- n = smartCtorId s

42+-- k = CI.mk (Text.takeWhile isLower n)

43+-- v = CI.mk (dropLower n)

44+-- go _ = Nothing

45+

46+-- assignPrefix :: Shape Related -> MemoP (Shape Prefixed)

47+-- assignPrefix = annotate Prefixed memo go

48+-- where

49+-- go :: (HasId a, HasRelation a) => Shape a -> MemoP (Maybe Text)

50+-- go (x :< s) =

51+-- let n = typeId (identifier x)

52+-- r = x ^. relation

53+-- in case s of

54+-- Enum _ vs -> Just <$> do

55+-- let hs = mempty : acronymPrefixes r n

56+-- ks = keys vs

57+-- unique r branches n hs ks

58+

59+-- Struct st -> Just <$> do

60+-- let hs = acronymPrefixes r n

61+-- ks = keys (st ^. members)

62+-- unique r fields n hs ks

63+

64+-- _ -> return Nothing

65+

66+-- unique :: Relation

67+-- -> Lens' Env Seen

68+-- -> Text

69+-- -> [CI Text]

70+-- -> Set (CI Text)

71+-- -> MemoP Text

72+-- unique r seen n [] ks = do

73+-- s <- use seen

74+-- let hs = acronymPrefixes r n

75+-- f x = sformat ("\n" % soriginal % " => " % shown) x (Map.lookup x s)

76+-- throwError $

77+-- format ("Error prefixing: " % stext %

78+-- ", fields: " % shown %

79+-- scomma)

80+-- n (Set.toList ks) (map f hs)

81+

82+-- unique r seen n (h:hs) ks = do

83+-- m <- uses seen (Map.lookup h)

84+-- -- Find if this particular naming heuristic is used already, and if

85+-- -- it is, then is there overlap with this set of ks?

86+-- case m of

87+-- Just ys | overlap ys ks

88+-- -> unique r seen n hs ks

89+-- _ -> do

90+-- seen %= Map.insertWith (<>) h ks

91+-- return (CI.original h)

92+

93+-- overlap :: (Eq a, Hashable a) => Set a -> Set a -> Bool

94+-- overlap xs ys = not . Set.null $ Set.intersection xs ys

95+

96+-- keys :: Map Id a -> Set (CI Text)

97+-- keys = Set.fromList . map (CI.mk . typeId) . Map.keys

98+

99+-- | Acronym preference list.

100+--

101+-- Prefixing occurs as follows:

102+-- * Requests - prefer acronyms

103+-- * Responses - prefer acronyms, and append 'rs'

104+-- * Shapes - prefer single letters, then acronyms

105+-- acronymPrefixes :: Id -> Id -- Text]

106+-- acronymPrefixes n =

107+-- where

108+-- -- rs = map (<> "rs") ss

109+-- ss = xs ++ map suffix ys

110+

111+-- -- Take the next char

112+-- suffix x = Text.snoc x c

113+-- where

114+-- c | Text.length x >= 2 = Text.head (Text.drop 1 x)

115+-- | otherwise = Text.head x

116+

117+-- xs = catMaybes [r1, r2, r3, r4, r5, r6]

118+-- ys = catMaybes [r1, r2, r3, r4, r6]

119+

120+-- a = camelAcronym n

121+-- a' = upperAcronym n

122+

123+-- limit = 3

124+

125+-- -- Full name if leq limit

126+-- r1 | Text.length n <= limit = Just n

127+-- | otherwise = Nothing

128+

129+-- -- VpcPeeringInfo -> VPI

130+-- r2 = toAcronym a

131+

132+-- -- VpcPeeringInfo -> VPCPI

133+-- r3 | x /= r2 = x

134+-- | otherwise = Nothing

135+-- where

136+-- x = toAcronym a'

137+

138+-- -- SomeTestTType -> S

139+-- r4 = Text.toUpper <$> safeHead n

140+

141+-- -- SomeTypes -> STS (retain pural)

142+-- r5 | Text.isSuffixOf "s" n = flip Text.snoc 's' <$> (r2 <|> r3)

143+-- | otherwise = Nothing

144+

145+-- -- SomeTestTType -> Som

146+-- r6 = Text.take limit <$> listToMaybe (splitWords a)

gen/src/Gen/Solve.hs+32−6

@@ -24,10 +24,17 @@ import Control.Error

2424import Control.Lens hiding (enum)

2525import Control.Monad.Except

2626import Control.Monad.State.Strict

27+import Data.CaseInsensitive (CI)

28+import qualified Data.CaseInsensitive as CI

29+import Data.Char (toLower)

2730import qualified Data.HashMap.Strict as Map

31+import qualified Data.HashSet as Set

2832import Data.List (intersect)

2933import Data.Maybe

3034import Data.Semigroup ((<>))

35+import Data.Text (Text)

36+import qualified Data.Text as Text

37+import Data.Text.Manipulate

3138import Gen.Formatting

3239import Gen.Types

3340import Prelude hiding (sum)

@@ -59,7 +66,8 @@ data Derive

5966 deriving (Eq, Show)

6067

6168data Solved = Solved

62− { _schema :: Schema Id

69+ { _prefix :: Pre

70+ , _schema :: Schema Id

6371 , _type :: TType

6472 , _deriving :: [Derive]

6573 }

@@ -69,14 +77,19 @@ instance HasInfo Solved where

6977 where

7078 f = lens _schema (\s a -> s { _schema = a })

7179

80+type Seen = Map (CI Text) (Set (CI Text))

81+

7282data Memo = Memo

73− { _typed :: Map Id TType

74− , _derived :: Map Id [Derive]

75− , _schemas :: Map Id (Schema Id)

83+ { _typed :: Map Id TType

84+ , _derived :: Map Id [Derive]

85+ , _prefixed :: Map Id Pre

86+ , _branches :: Seen

87+ , _fields :: Seen

88+ , _schemas :: Map Id (Schema Id)

7689 }

7790

7891initial :: Map Id (Schema Id) -> Memo

79−initial = Memo mempty mempty

92+initial = Memo mempty mempty mempty mempty mempty

8093

8194makeLenses ''Memo

8295

@@ -100,7 +113,7 @@ memo l k f = do

100113 return x

101114

102115solve :: Id -> AST Solved

103−solve k = Solved <$> schema k <*> typeOf k <*> derive k

116+solve k = Solved <$> prefix k <*> schema k <*> typeOf k <*> derive k

104117

105118typeOf :: Id -> AST TType

106119typeOf k = loc "typeOf" k $ memo typed k go

@@ -140,5 +153,18 @@ derive k = loc "derive" k $ memo derived k go

140153 enum = [DOrd, DEnum]

141154 base = [DEq, DRead, DShow, DData, DTypeable, DGeneric]

142155

156+prefix :: Id -> AST Pre

157+prefix k = loc "prefix" k $ memo prefixed k go

158+ where

159+ go (Obj i rs) = Map.traverseWithKey prop rs >> pure (Pre k)

160+ go s = pure (Pre k)

161+

162+ prop n _ = do

163+ let p = Pre (idFromText (acronym $ idToText k) <> n)

164+ prefixed %= Map.insert (k <> n) p

165+ pure p

166+

167+ acronym = foldMap (Text.singleton . toLower . Text.head) . splitWords

168+

143169loc :: String -> Id -> a -> a

144170loc _ _ = id -- trace (n ++ ": " ++ Text.unpack (refToText r))

gen/src/Gen/Syntax.hs+25−34

@@ -13,7 +13,8 @@

1313

1414module Gen.Syntax where

1515

16−import Control.Lens hiding (iso, mapping, op, strict)

16+import Control.Lens hiding (iso, mapping, op, pre,

17+ strict)

1718import Data.Foldable (foldr')

1819import Data.Hashable

1920import qualified Data.HashMap.Strict as Map

@@ -23,6 +24,7 @@ import Data.String

2324import Data.Text (Text)

2425import qualified Data.Text as Text

2526import Data.Text.Manipulate

27+import Gen.Orphans

2628import Gen.Solve

2729import Gen.Text

2830import Gen.Types

@@ -30,12 +32,6 @@ import Language.Haskell.Exts.Build

3032import Language.Haskell.Exts.SrcLoc

3133import Language.Haskell.Exts.Syntax hiding (Int)

3234

33−instance Hashable Name

34−

35−instance IsString Name where fromString = name

36−instance IsString QName where fromString = UnQual . name

37−instance IsString QOp where fromString = op . sym

38−

3935apiTypes :: Service s r -> Id -> Method -> [Type]

4036apiTypes s r m = map sing ps ++ qs ++ [end]

4137 where

@@ -59,14 +55,14 @@ apiTypes s r m = map sing ps ++ qs ++ [end]

5955

6056 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mMethod m)

6157 typ = tycon "'[JSON]"

62− res = maybe (tycon "()") tycon (_mResponse m)

58+ res = maybe (tycon "()") (tycon . Pre) (_mResponse m)

6359

6460 -- method (titlecase) '[JSON] (responsetype)

6561

66−objDecl :: Id -> Map Id Solved -> AST Decl

67−objDecl r rs = DataDecl noLoc arity [] d [] [conDecl d rs] <$> derivings r

62+objDecl :: Id -> Pre -> Map Id Solved -> AST Decl

63+objDecl r p rs = DataDecl noLoc arity [] d [] [conDecl d rs] <$> derivings r

6864 where

69− d = dname r

65+ d = dname p

7066

7167 arity | Map.size rs == 1 = NewType

7268 | otherwise = DataType

@@ -74,14 +70,14 @@ objDecl r rs = DataDecl noLoc arity [] d [] [conDecl d rs] <$> derivings r

7470conDecl :: Name -> Map Id Solved -> QualConDecl

7571conDecl n rs = QualConDecl noLoc [] [] body

7672 where

77− body = case Map.toList rs of

73+ body = case Map.elems rs of

7874 [] -> ConDecl n []

7975 [x] -> RecDecl n [field internal x]

8076 xs -> RecDecl n (map (field (strict . internal)) xs)

8177

82− field f (k, v) = ([fname k], f (_type v))

78+ field f v = ([fname (_prefix v)], f (_type v))

8379

84−ctorSig :: Id -> Map Id Solved -> Decl

80+ctorSig :: Pre -> Map Id Solved -> Decl

8581ctorSig r rs = TypeSig noLoc [c] ts

8682 where

8783 c = cname r

@@ -90,7 +86,7 @@ ctorSig r rs = TypeSig noLoc [c] ts

9086 ts = foldr' TyFun (TyCon (UnQual d)) ps

9187 ps = parameters (Map.elems rs)

9288

93−ctorDecl :: Id -> Map Id Solved -> Decl

89+ctorDecl :: Pre -> Map Id Solved -> Decl

9490ctorDecl r rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds

9591 where

9692 c = cname r

@@ -98,30 +94,31 @@ ctorDecl r rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds

9894

9995 rhs | Map.null rs = var d

10096 | otherwise = RecConstr (UnQual d) $

101− map (uncurry fieldUpdate) (Map.toList rs)

97+ map fieldUpdate (Map.elems rs)

10298

103− ps = map pname . Map.keys $ Map.filter (view required) rs

99+ ps = map (pname . _prefix) . Map.elems $ Map.filter (view required) rs

104100

105−fieldUpdate :: Id -> Solved -> FieldUpdate

106−fieldUpdate r s = FieldUpdate (UnQual (fname r)) rhs

101+fieldUpdate :: Solved -> FieldUpdate

102+fieldUpdate s = FieldUpdate (UnQual (fname n)) rhs

107103 where

108104 rhs | s ^. required = p

109105 | Just x <- s ^. defaulted = str x

110106 | Just v <- iso (_type s) = infixApp v "#" p

111107 | otherwise = var (name "Nothing")

112108

113− p = var (pname r)

109+ p = var (pname n)

110+ n = _prefix s

114111

115−lensSig :: Id -> Id -> Solved -> Decl

116−lensSig n r s = TypeSig noLoc [lname r] $

112+lensSig :: Pre -> Solved -> Decl

113+lensSig n s = TypeSig noLoc [lname (_prefix s)] $

117114 TyApp (TyApp (tycon "Lens'") (tycon n))

118115 (external (_type s))

119116

120−lensDecl :: Id -> Solved -> Decl

117+lensDecl :: Pre -> Solved -> Decl

121118lensDecl r s = sfun noLoc l [] (UnGuardedRhs rhs) noBinds

122119 where

123− l = lname r

124120 f = fname r

121+ l = lname (_prefix s)

125122 t = _type s

126123

127124 rhs = mapping t $

@@ -129,14 +126,8 @@ lensDecl r s = sfun noLoc l [] (UnGuardedRhs rhs) noBinds

129126 (paren (lamE noLoc [pvar "s", pvar "a"]

130127 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))

131128

132−enumDecl :: Decl

133−enumDecl = emptyDecl

134−

135−emptyDecl :: Decl

136−emptyDecl = DataDecl noLoc DataType [] (name "Empty") [] [] []

137−

138129derivings :: Id -> AST [Deriving]

139−derivings = fmap (map ((,[]) . unqual . drop 1 . show)) . derive

130+derivings k = map ((,[]) . unqual . drop 1 . show) <$> derive k

140131

141132parameters :: [Solved] -> [Type]

142133parameters = map (external . _type) . filter (view required)

@@ -144,7 +135,7 @@ parameters = map (external . _type) . filter (view required)

144135external, internal :: TType -> Type

145136external = internal

146137internal = \case

147− TType r -> tycon r

138+ TType r -> tycon (Pre r)

148139 TMaybe t -> TyApp (tycon "Maybe") (internal t)

149140 TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)

150141 TList t -> TyList (internal t)

@@ -188,8 +179,8 @@ strict = TyBang BangedTy . \case

188179sing :: Text -> Type

189180sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""

190181

191−tycon :: Id -> Type

192−tycon = TyCon . unqual . ref upperHead

182+tycon :: Pre -> Type

183+tycon = TyCon . unqual . pre upperHead

193184

194185unqual :: String -> QName

195186unqual = UnQual . name

gen/src/Gen/Types.hs+13−9

@@ -38,6 +38,7 @@ import Data.Bifunctor

3838import Data.Char

3939import Data.Function (on)

4040import qualified Data.HashMap.Strict as Map

41+import qualified Data.HashSet as Set

4142import Data.List.NonEmpty (NonEmpty (..))

4243import qualified Data.List.NonEmpty as NE

4344import Data.Maybe

@@ -50,6 +51,7 @@ import qualified Data.Text.Lazy.Builder as Build

5051import qualified Data.Text.Read as Read

5152import qualified Filesystem.Path.CurrentOS as Path

5253import Formatting

54+import Gen.Orphans

5355import Gen.Text

5456import Gen.Types.Help

5557import Gen.Types.Id

@@ -65,6 +67,7 @@ default (Text)

6567

6668newtype Fix f = Fix (f (Fix f))

6769

70+type Set = Set.HashSet

6871type Error = LText.Text

6972type Rendered = LText.Text

7073type Path = Path.FilePath

@@ -289,16 +292,17 @@ instance ToJSON Fun where

289292 ]

290293

291294data Data

292− = Sum Name (Maybe Help) Rendered

295+ = Sum Name (Maybe Help) (Map Name Text) [Help]

293296 | Prod Name (Maybe Help) Rendered Fun [Fun]

294297

295298instance ToJSON Data where

296299 toJSON = \case

297− Sum n h d -> object

298− [ "name" .= Syn n

299− , "type" .= "sum"

300− , "decl" .= d

301− , "help" .= h

300+ Sum n h vs ds -> object

301+ [ "name" .= Syn n

302+ , "type" .= "sum"

303+ , "help" .= h

304+ , "ctors" .= vs

305+ , "descriptions" .= ds

302306 ]

303307

304308 Prod n h d c ls -> object

@@ -315,7 +319,7 @@ data API = API Name (Map Name [Rendered])

315319instance ToJSON API where

316320 toJSON (API n ms) = object

317321 [ "name" .= Syn n

318− , "methods" .= Map.fromList (map (first prettyPrint) $ Map.toList ms)

322+ , "methods" .= ms

319323 ]

320324

321325data Method = Method

@@ -382,11 +386,11 @@ instance ToJSON (Service Data API) where

382386 Object x = genericToJSON (js "_svc") s

383387 Object y = object

384388 [ "exposedModules" .= exposedModules s

385− , "api" .= Syn (aname (idFromText (_svcName s)))

389+ , "api" .= svcAbbrev s

386390 ]

387391

388392svcAbbrev :: Service s r -> Text

389−svcAbbrev = renameAbbrev . _svcTitle

393+svcAbbrev s = renameAbbrev $ fromMaybe (_svcTitle s) (_svcCanonicalName s)

390394

391395typeImports :: Service s r -> [NS]

392396typeImports _ = ["Network.Google.Prelude"]

gen/src/Gen/Types/Id.hs+24−10

@@ -1,6 +1,7 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE LambdaCase #-}

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE LambdaCase #-}

56-- Module : Gen.Types.Id

@@ -11,14 +12,17 @@

1112

1213module Gen.Types.Id

1314 ( Id

15+ , Pre (..)

1416

1517 -- * Conversion

1618 , idToText

1719 , idFromText

20+ , direct

1821

1922 -- * Formatting

2023 , fid

2124 , ref

25+ , pre

2226

2327 -- * Syntax

2428 , aname

@@ -31,7 +35,7 @@ module Gen.Types.Id

3135 ) where

3236

3337import Control.Applicative

34−import Control.Lens hiding ((.=))

38+import Control.Lens hiding (pre, (.=))

3539import Data.Aeson hiding (Bool, String)

3640import Data.Aeson.TH

3741import qualified Data.Attoparsec.Text as A

@@ -56,18 +60,24 @@ import GHC.Generics

5660import Language.Haskell.Exts.Build

5761import Language.Haskell.Exts.Syntax (Name)

5862

63+newtype Pre = Pre Id

64+ deriving (IsString)

65+

5966aname :: Id -> Name

6067aname = name . ref upperHead

6168

6269mname :: Id -> Id -> Name

6370mname p k = aname (p <> k)

6471

65−dname, cname, fname, lname, pname :: Id -> Name

66−dname = name . ref upperHead

67−cname = name . ref (renameReserved . lowerHead)

68−fname = name . ref (Text.cons '_' . lowerHead)

69−lname = name . ref lowerHead

70−pname = name . ref (flip Text.snoc '_' . Text.cons 'p' . upperHead)

72+dname, cname, fname, lname, pname :: Pre -> Name

73+dname = name . pre upperHead

74+cname = name . pre (renameReserved . lowerHead)

75+fname = name . pre (Text.cons '_' . lowerHead)

76+lname = name . pre lowerHead

77+pname = name . pre (flip Text.snoc '_' . Text.cons 'p' . upperHead)

78+

79+pre :: (Text -> Text) -> Pre -> String

80+pre f (Pre k) = ref f k

7181

7282ref :: (Text -> Text) -> Id -> String

7383ref f = Text.unpack . f . idToText

@@ -109,3 +119,7 @@ idFromText = Direct

109119

110120fid :: Format a (Id -> a)

111121fid = later (Build.fromText . idToText)

122+

123+direct :: Id -> Id

124+direct (Direct x) = Direct x

125+direct (Opaque xs) = Direct (last xs)