@@ -10,29 +10,29 @@
1010-- Stability : provisional
1111-- Portability : non-portable (GHC extensions)
1212
13−module Gen.Types.Id
14− ( Id
15− , Pre (..)
16−
17− -- * Conversion
18− , idToText
19− , idFromText
20− , direct
21−
22− -- * Formatting
23− , fid
24− , ref
25− , pre
26−
27− -- * Syntax
28− , aname
29− , mname
30− , dname
31− , cname
32− , fname
33− , lname
34− , pname
35− ) where
13+module Gen.Types.Id where
14+ -- ( Id
15+ -- , Pre (..)
16+
17+ -- -- * Conversion
18+ -- , idToText
19+ -- , idFromText
20+ -- , direct
21+
22+ -- -- * Formatting
23+ -- , fid
24+ -- , ref
25+ -- , pre
26+
27+ -- -- * Syntax
28+ -- , aname
29+ -- , mname
30+ -- , dname
31+ -- , cname
32+ -- , fname
33+ -- , lname
34+ -- , pname
35+ -- ) where
3636
3737import Control.Applicative
3838import Control.Lens hiding (pre, (.=))
@@ -44,6 +44,8 @@ import Data.Char
4444import Data.Function (on)
4545import Data.Hashable
4646import qualified Data.HashMap.Strict as Map
47+import Data.List.NonEmpty (NonEmpty (..))
48+import qualified Data.List.NonEmpty as NE
4749import Data.Maybe
4850import Data.Ord
4951import Data.Semigroup hiding (Sum)
@@ -60,66 +62,100 @@ import GHC.Generics
6062import Language.Haskell.Exts.Build
6163import Language.Haskell.Exts.Syntax (Name)
6264
63−newtype Pre = Pre Id
64− deriving (IsString)
65−
6665aname :: Id -> Name
67−aname = name . ref upperHead
66+aname = name . Text.unpack . upperHead . idToText
6867
69−mname :: Id -> Id -> Name
70−mname p k = aname (p <> k)
68+mname :: Id -> Global -> Name
69+mname x y = name . Text.unpack $
70+ upperHead (idToText x) <> upperHead (global y)
7171
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)
72+dname, cname :: Id -> Name
73+dname = name . Text.unpack . upperHead . idToText
74+cname = name . Text.unpack . renameReserved . lowerHead . idToText
7875
79−pre :: (Text -> Text) -> Pre -> String
80−pre f (Pre k) = ref f k
76+bname :: Pre -> Text -> Name
77+bname (Pre p) = name
78+ . Text.unpack
79+ . mappend (Text.toUpper p)
80+ . upperHead
8181
82−ref :: (Text -> Text) -> Id -> String
83−ref f = Text.unpack . f . idToText
82+fname, lname, pname :: Pre -> Local -> Name
83+fname = pre (Text.cons '_' . lowerHead)
84+lname = pre lowerHead
85+pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead)
8486
85−data Id
86− = Opaque [Text]
87− | Direct Text
88− deriving (Eq, Show, Generic)
87+pre :: (Text -> Text) -> Pre -> Local -> Name
88+pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local
8989
90−instance Semigroup Id where
91− a <> b = case (a, b) of
92− (Opaque xs, Opaque ys) -> Opaque (xs <> ys)
93− (Opaque xs, Direct y) -> Opaque (xs <> [y])
94− (Direct x, Opaque ys) -> Opaque (x : ys)
95− (Direct x, Direct y) -> Opaque [x, y]
90+newtype Global = Global { global :: Text }
91+ deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)
9692
97−instance IsString Id where
98− fromString = idFromText . fromString
93+instance FromJSON a => FromJSON (Map Global a) where
94+ parseJSON = fmap (fromMap Global) . parseJSON
95+
96+instance ToJSON a => ToJSON (Map Global a) where
97+ toJSON = toJSON . toMap global
98+
99+gid :: Format a (Global -> a)
100+gid = later (Build.fromText . global)
101+
102+newtype Local = Local { local :: Text }
103+ deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)
104+
105+instance FromJSON a => FromJSON (Map Local a) where
106+ parseJSON = fmap (fromMap Local) . parseJSON
107+
108+instance ToJSON a => ToJSON (Map Local a) where
109+ toJSON = toJSON . toMap local
110+
111+lid :: Format a (Local -> a)
112+lid = later (Build.fromText . local)
113+
114+data Id
115+ = Free Global
116+ | Bound Global (NonEmpty Local)
117+ deriving (Eq, Show, Generic)
99118
100119instance Hashable Id
101120
102−instance FromJSON Id where parseJSON = withText "id" (pure . idFromText)
103−instance ToJSON Id where toJSON = toJSON . idToText
121+instance IsString Id where
122+ fromString = Free . Global . fromString
104123
105124instance FromJSON a => FromJSON (Map Id a) where
106− parseJSON o = Map.fromList . map (first idFromText) . Map.toList
107− <$> parseJSON o
125+ parseJSON = fmap (fromMap (Free . Global)) . parseJSON
108126
109127instance ToJSON a => ToJSON (Map Id a) where
110− toJSON = toJSON . Map.fromList . map (first idToText) . Map.toList
128+ toJSON = toJSON . toMap idToText
111129
112−idToText :: Id -> Text
113−idToText = renameReserved . \case
114− Opaque xs -> mconcat (map upperHead xs)
115− Direct n -> n
130+newtype Pre = Pre Text
131+ deriving (Show, Monoid)
116132
117−idFromText :: Text -> Id
118−idFromText = Direct
133+mkId :: Global -> [Local] -> Id
134+mkId g = \case
135+ [] -> Free g
136+ x:xs -> Bound g (x :| xs)
137+
138+mkProp :: Id -> Local -> Id
139+mkProp n x =
140+ case n of
141+ Free g -> Bound g (x :| [])
142+ Bound g xs -> Bound g (NE.cons x xs)
143+
144+revProp :: Id -> Local
145+revProp = \case
146+ Free g -> Local (global g)
147+ Bound _ xs -> let x :| _ = NE.reverse xs in x
148+
149+idToText :: Id -> Text
150+idToText = renameReserved . upperHead . \case
151+ Free g -> global g
152+ Bound g ls -> mconcat (global g : map (upperHead . local) (NE.toList ls))
119153
120154fid :: Format a (Id -> a)
121155fid = later (Build.fromText . idToText)
122156
123−direct :: Id -> Id
124−direct (Direct x) = Direct x
125−direct (Opaque xs) = Direct (last xs)
157+fromMap :: (Eq a, Hashable a) => (Text -> a) -> Map Text b -> Map a b
158+fromMap f = Map.fromList . map (first f) . Map.toList
159+
160+toMap :: (a -> Text) -> Map a b -> Map Text b
161+toMap f = Map.fromList . map (first f) . Map.toList