{-# LANGUAGE OverloadedStrings, FlexibleContexts, TupleSections, TypeOperators #-}

module CDP.Gen.Program
    ( Program (..)
    , genProgram
    , genProtocolModule

    , ComponentName (..)
    ) where

import Control.Arrow
import Data.List
import Data.Maybe
import Data.Char
import Control.Monad
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Graph as Graph
import qualified Data.Text as T

import qualified CDP.Definition as D
import qualified CDP.Gen.Snippets as Snippets

----------- Start of program generation ----------- 

data Program = Program
    { Program -> Map ComponentName Text
pComponents       :: Map.Map ComponentName T.Text
    , Program -> Text
pComponentImports :: T.Text
    }

data Context = Context { Context -> DomainComponents
ctxDomainComponents :: DomainComponents }

genProgram :: [D.Domain] -> Program
genProgram :: [Domain] -> Program
genProgram [Domain]
delts = Program :: Map ComponentName Text -> Text -> Program
Program
    { pComponents :: Map ComponentName Text
pComponents        = Context -> [Component] -> Map ComponentName Text
allComponents Context
ctx ([Component] -> Map ComponentName Text)
-> [Component] -> Map ComponentName Text
forall a b. (a -> b) -> a -> b
$ DomainComponents -> [Component]
forall k a. Map k a -> [a]
Map.elems DomainComponents
dc
    , pComponentImports :: Text
pComponentImports  = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Context -> [Text]
allComponentImports Context
ctx
    }
  where
    ctx :: Context
ctx    = DomainComponents -> Context
Context DomainComponents
dc
    dc :: DomainComponents
dc     = [Domain] -> DomainComponents
domainComponents [Domain]
delts

----------- Generation of global types / values ----------- 

genProtocolModule :: [ComponentName] -> T.Text -> T.Text
genProtocolModule :: [ComponentName] -> Text -> Text
genProtocolModule [ComponentName]
names Text
source = [Text] -> Text
T.unlines
    [ Text
"{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections #-}"
    , Text
"{-# LANGUAGE ScopedTypeVariables #-}"
    , Text
"{-# LANGUAGE FlexibleContexts #-}"
    , Text
"{-# LANGUAGE MultiParamTypeClasses #-}"
    , Text
"{-# LANGUAGE FlexibleInstances #-}"
    , Text
"{-# LANGUAGE DeriveGeneric #-}"
    , Text
""
    , [ComponentName] -> Text
protocolModuleHeader [ComponentName]
names
    , Text
Snippets.domainImports
    , Text
source
    ]

allComponentImports :: Context -> [T.Text]
allComponentImports :: Context -> [Text]
allComponentImports = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> (Context -> Set Text) -> Context -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> (Context -> [Text]) -> Context -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
    (Component -> [Text]) -> [Component] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\Text
n -> [Bool -> Text -> Text
importDomain Bool
False Text
n, Bool -> Text -> Text
importDomain Bool
True Text
n]) (Text -> [Text]) -> (Component -> Text) -> Component -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentName -> Text
unComponentName (ComponentName -> Text)
-> (Component -> ComponentName) -> Component -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> ComponentName
cName) ([Component] -> [Text])
-> (Context -> [Component]) -> Context -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DomainComponents -> [Component]
forall k a. Map k a -> [a]
Map.elems (DomainComponents -> [Component])
-> (Context -> DomainComponents) -> Context -> [Component]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> DomainComponents
ctxDomainComponents

allComponents :: Context -> [Component] -> Map.Map ComponentName T.Text
allComponents :: Context -> [Component] -> Map ComponentName Text
allComponents Context
ctx [Component]
components = [(ComponentName, Text)] -> Map ComponentName Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ComponentName, Text)] -> Map ComponentName Text)
-> ([Component] -> [(ComponentName, Text)])
-> [Component]
-> Map ComponentName Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
    (Component -> (ComponentName, Text))
-> [Component] -> [(ComponentName, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Component -> ComponentName
cName (Component -> ComponentName)
-> (Component -> Text) -> Component -> (ComponentName, Text)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Context -> Component -> Text
genComponent Context
ctx) ([Component] -> Map ComponentName Text)
-> [Component] -> Map ComponentName Text
forall a b. (a -> b) -> a -> b
$ 
    [Component]
components

----------- Generation of domain types / values -----------

genComponent :: Context -> Component -> T.Text
genComponent :: Context -> Component -> Text
genComponent Context
ctx Component
component = Text -> [Text] -> Text
T.intercalate Text
"\n\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [ Text
Snippets.domainLanguageExtensions
    , Component -> Text
formatComponentDescription Component
component
    , Text -> Text
domainModuleHeader Text
cn
    , Text
Snippets.domainImports
    , [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Text -> Text
importDomain Bool
True) [Text]
deps
    , [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Domain -> Text) -> [Domain] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Domain -> Text
genDomain Context
ctx) [Domain]
delts
    ]
  where
    deps :: [Text]
deps  = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text])
-> (Map Text (Domain, [Text]) -> Set Text)
-> Map Text (Domain, [Text])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text)
-> (Map Text (Domain, [Text]) -> [Text])
-> Map Text (Domain, [Text])
-> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComponentName -> Text) -> [ComponentName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ComponentName -> Text
unComponentName ([ComponentName] -> [Text])
-> (Map Text (Domain, [Text]) -> [ComponentName])
-> Map Text (Domain, [Text])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
        (Text -> ComponentName) -> [Text] -> [ComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Text -> ComponentName
domainToComponentName Context
ctx) ([Text] -> [ComponentName])
-> (Map Text (Domain, [Text]) -> [Text])
-> Map Text (Domain, [Text])
-> [ComponentName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Domain, [Text]) -> [Text]) -> [(Domain, [Text])] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Domain, [Text]) -> [Text]
forall a b. (a, b) -> b
snd ([(Domain, [Text])] -> [Text])
-> (Map Text (Domain, [Text]) -> [(Domain, [Text])])
-> Map Text (Domain, [Text])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Domain, [Text]) -> [(Domain, [Text])]
forall k a. Map k a -> [a]
Map.elems (Map Text (Domain, [Text]) -> [Text])
-> Map Text (Domain, [Text]) -> [Text]
forall a b. (a -> b) -> a -> b
$ Component -> Map Text (Domain, [Text])
cDomDeps Component
component
    delts :: [Domain]
delts = ((Domain, [Text]) -> Domain) -> [(Domain, [Text])] -> [Domain]
forall a b. (a -> b) -> [a] -> [b]
map (Domain, [Text]) -> Domain
forall a b. (a, b) -> a
fst ([(Domain, [Text])] -> [Domain])
-> (Map Text (Domain, [Text]) -> [(Domain, [Text])])
-> Map Text (Domain, [Text])
-> [Domain]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Domain, [Text]) -> [(Domain, [Text])]
forall k a. Map k a -> [a]
Map.elems (Map Text (Domain, [Text]) -> [Domain])
-> Map Text (Domain, [Text]) -> [Domain]
forall a b. (a -> b) -> a -> b
$ Component -> Map Text (Domain, [Text])
cDomDeps Component
component
    cn :: Text
cn    = ComponentName -> Text
unComponentName (ComponentName -> Text)
-> (Component -> ComponentName) -> Component -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> ComponentName
cName (Component -> Text) -> Component -> Text
forall a b. (a -> b) -> a -> b
$ Component
component

genDomain :: Context -> D.Domain -> T.Text
genDomain :: Context -> Domain -> Text
genDomain Context
ctx Domain
domainElt = [Text] -> Text
T.unlines ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[Text]] -> [Text]
forall a. [a] -> [[a]] -> [a]
intercalate [Text
""] ([[Text]] -> Text) -> [[Text]] -> Text
forall a b. (a -> b) -> a -> b
$
    (Type -> [Text]) -> [Type] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Text -> Type -> [Text]
genType Context
ctx Text
dn)            (Domain -> [Type]
D.domainTypes    Domain
domainElt) [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++
    (Event -> [Text]) -> [Event] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Text -> Event -> [Text]
genEventReturnType Context
ctx Text
dn) (Domain -> [Event]
D.domainEvents   Domain
domainElt) [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++
    (Command -> [Text]) -> [Command] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Text -> Command -> [Text]
genCommand Context
ctx Text
dn)         (Domain -> [Command]
D.domainCommands Domain
domainElt)
  where
    dn :: Text
dn    = Domain -> Text
domainName Domain
domainElt

genType :: Context -> T.Text -> D.Type -> [T.Text]
genType :: Context -> Text -> Type -> [Text]
genType Context
ctx Text
domainName Type
telt =
    [Text]
desc [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    (case Type -> Maybe [Text]
D.typeEnum Type
telt of
        Just [Text]
enumValues -> Context -> Text -> [Text] -> [Text]
genTypeEnum Context
ctx Text
tn [Text]
enumValues
        Maybe [Text]
Nothing         -> case Text
tytelt of
            Text
"object" -> case Maybe [Property]
tpeltsM of
                Maybe [Property]
Nothing ->  [Context -> Text -> Text -> Text
genTypeSynonynm Context
ctx Text
domainName Text
tn]
                Just [Property]
tpelts ->
                    Context -> Text -> Text -> [Property] -> [Text]
genRecordType Context
ctx Text
domainName Text
tn [Property]
tpelts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
                    Text -> [Property] -> [Text]
genRecordFromJson Text
tn [Property]
tpelts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
                    Text -> [Property] -> [Text]
genRecordToJson Text
tn [Property]
tpelts
            Text
ty -> [[Text] -> Text
T.unwords [Text
"type", Text
tn, Text
"=", Text
lty]])
  where
    desc :: [Text]
desc     = Maybe Text -> [Text]
formatDescription (Maybe Text -> [Text]) -> (Text -> Maybe Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
        Text
"Type '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
domainName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
D.typeId Type
telt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\Text
x -> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x) (Type -> Maybe Text
D.typeDescription Type
telt)
    lty :: Text
lty      = Context -> Text -> Maybe Text -> Maybe Text -> Maybe Items -> Text
leftType Context
ctx Text
domainName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
tytelt) Maybe Text
forall a. Maybe a
Nothing (Type -> Maybe Items
D.typeItems Type
telt)
    tytelt :: Text
tytelt   = Type -> Text
D.typeType Type
telt
    tpeltsM :: Maybe [Property]
tpeltsM  = Type -> Maybe [Property]
D.typeProperties Type
telt
    tn :: Text
tn       = Text -> Type -> Text
typeNameHS Text
domainName Type
telt 

genTypeEnum :: Context -> T.Text -> [T.Text] -> [T.Text]
genTypeEnum :: Context -> Text -> [Text] -> [Text]
genTypeEnum Context
_ Text
typeEnumName [Text]
values =
    [[Text] -> Text
T.unwords [Text
"data", Text
typeEnumName, Text
"=", Text -> [Text] -> Text
T.intercalate Text
" | " [Text]
constructors]] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text] -> [Text]
indent [Text
derivingOrd] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    Text -> [Text] -> [Text] -> [Text]
genFromJSONInstanceEnum Text
typeEnumName [Text]
values [Text]
constructors [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    Text -> [Text] -> [Text] -> [Text]
genToJSONInstanceEnum Text
typeEnumName [Text]
values [Text]
constructors
  where
    constructors :: [Text]
constructors = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
tyNameHS Text
typeEnumName) [Text]
values

genEventReturnType :: Context -> T.Text -> D.Event -> [T.Text]
genEventReturnType :: Context -> Text -> Event -> [Text]
genEventReturnType Context
ctx Text
domainName Event
eventElt =
    [Text]
desc [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    (case [Property]
evelts of
        [] -> [Text
"data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
evrn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
evrn] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text] -> [Text]
indent [Text
derivingBase]
        [Property]
_ -> Context -> Text -> Text -> [Property] -> [Text]
genRecordType Context
ctx Text
domainName Text
evrn [Property]
evelts) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    (Text -> [Property] -> [Text]
genRecordFromJson Text
evrn [Property]
evelts) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text
"instance Event " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
evrn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text] -> [Text]
indent [Text
"eventName _ = \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Event -> Text
eventName Text
domainName Event
eventElt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""]
  where
    desc :: [Text]
desc = Maybe Text -> [Text]
formatDescription (Maybe Text -> [Text]) -> (Text -> Maybe Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
"Type of the '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        (Text -> Event -> Text
eventName Text
domainName Event
eventElt) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' event."
    evelts :: [Property]
evelts = Event -> [Property]
D.eventParameters Event
eventElt
    evrn :: Text
evrn = Text -> Event -> Text
eventNameHS Text
domainName Event
eventElt

genCommand :: Context -> T.Text -> D.Command -> [T.Text]
genCommand :: Context -> Text -> Command -> [Text]
genCommand Context
ctx Text
domainName Command
commandElt =
    Maybe Text -> [Text]
formatDescription (Command -> Maybe Text
D.commandDescription Command
commandElt) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text
""] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    Maybe Text -> [Text]
formatDescription (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"Parameters of the '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' command.") [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    Context -> Text -> Text -> [Property] -> [Text]
genRecordType Context
ctx Text
domainName Text
ptn [Property]
pelts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    Context -> Text -> Text -> [Property] -> [Text]
genRecordSmartConstructor Context
ctx Text
domainName Text
ptn [Property]
pelts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    Text -> [Property] -> [Text]
genRecordToJson Text
ptn [Property]
pelts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    (if [Property] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Property]
relts then [] else Context -> Text -> Text -> [Property] -> [Text]
genRecordType Context
ctx Text
domainName Text
rtn [Property]
relts) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    (if [Property] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Property]
relts then [] else Text -> [Property] -> [Text]
genRecordFromJson Text
rtn [Property]
relts) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text]
commandInstance
  where
    cn :: Text
cn   = Text -> Command -> Text
commandName Text
domainName Command
commandElt 
    ptn :: Text
ptn  = Text -> Command -> Text
commandParamsNameHS Text
domainName Command
commandElt
    rtn :: Text
rtn  = Text -> Command -> Text
commandNameHS Text
domainName Command
commandElt

    pelts :: [Property]
pelts = Command -> [Property]
D.commandParameters Command
commandElt

    relts :: [Property]
relts = Command -> [Property]
D.commandReturns Command
commandElt

    commandAssociatedType :: Text
commandAssociatedType = if [Property] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Property]
relts then Text
"()" else Text
rtn
    commandInstance :: [Text]
commandInstance =
        [Text
"instance Command " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
        [Text] -> [Text]
indent [Text
"type CommandResponse " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commandAssociatedType] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
        [Text] -> [Text]
indent [Text
"commandName _ = \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
        [Text] -> [Text]
indent [Text
"fromJSON = const . A.Success . const ()" | ([Property] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Property]
relts)]

genRecordType :: Context -> T.Text -> T.Text -> [D.Property] -> [T.Text]
genRecordType :: Context -> Text -> Text -> [Property] -> [Text]
genRecordType Context
ctx Text
domainName Text
recName [Property]
props =
    (do
        Property
p <- [Property]
props
        [Text]
e <- Maybe [Text] -> [[Text]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Text] -> [[Text]]) -> Maybe [Text] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ Property -> Maybe [Text]
D.propertyEnum Property
p
        Context -> Text -> [Text] -> [Text]
genTypeEnum Context
ctx (Text -> Text -> Text
tyNameHS Text
"" (Text -> Text -> Text
fieldNameHS Text
recName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Property -> Text
D.propertyName Property
p)) [Text]
e) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [ Text
"data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
recName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
recName] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ case [Property]
props of
        [] -> []
        [Property]
_ ->
            [Text
"{"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
            ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
                (Bool
isLast, Property
prop) <- [Property] -> [(Bool, Property)]
forall a. [a] -> [(Bool, a)]
markLast [Property]
props
                let (Text
fn, Text
fty) = Context -> Text -> Text -> Property -> (Text, Text)
propertyHsSig Context
ctx Text
domainName Text
recName Property
prop
                    comma :: Text
comma = if Bool
isLast then Text
"" else Text
","
                Maybe Text -> [Text]
formatDescription (Property -> Maybe Text
D.propertyDescription Property
prop) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
                    [Text
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
comma]) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
            [Text
"}"]) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text
"  deriving (Eq, Show)"]

genRecordSmartConstructor :: Context -> T.Text -> T.Text -> [D.Property] -> [T.Text]
genRecordSmartConstructor :: Context -> Text -> Text -> [Property] -> [Text]
genRecordSmartConstructor Context
ctx Text
domainName Text
recName [Property]
props =
    [Text
conName] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
        (Bool
isFirstParam, (Maybe Text
mbDesc, Text
ty)) <- [(Maybe Text, Text)] -> [(Bool, (Maybe Text, Text))]
forall a. [a] -> [(Bool, a)]
markFirst [(Maybe Text, Text)]
types
        let d1 :: [Text]
d1 = Maybe Text -> [Text]
formatDescription Maybe Text
mbDesc
            d2 :: [Text]
d2 
                | [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
d1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [Text]
d1
                | Bool
otherwise      = Text
"{-" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
d1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"-}"]
        [Text]
d2 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
            [(if Bool
isFirstParam then Text
":: " else Text
"-> ") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty]) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text
conName] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text] -> [Text]
indent [Text]
args [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text] -> [Text]
indent [Text
"= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
recName] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    ([Text] -> [Text]
indent ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
        Property
prop <- [Property]
props
        Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ if Property -> Bool
D.propertyOptional Property
prop
            then Text
"Nothing"
            else Property -> Text
argName Property
prop)
  where
    conName :: Text
conName = Text -> Text
uncapitalizeFirst Text
recName
    requiredProps :: [Property]
requiredProps = (Property -> Bool) -> [Property] -> [Property]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Property -> Bool) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Bool
D.propertyOptional) [Property]
props
    types :: [(Maybe Text, Text)]
types = (do
        Property
prop <- [Property]
requiredProps
        let (Text
_, Text
ty) = Context -> Text -> Text -> Property -> (Text, Text)
propertyHsSig Context
ctx Text
domainName Text
recName Property
prop
        (Maybe Text, Text) -> [(Maybe Text, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Maybe Text
D.propertyDescription Property
prop, Text
ty)) [(Maybe Text, Text)]
-> [(Maybe Text, Text)] -> [(Maybe Text, Text)]
forall a. [a] -> [a] -> [a]
++
        [ (Maybe Text
forall a. Maybe a
Nothing, Text
recName) ]
    args :: [Text]
args = do
        Property
prop <- [Property]
requiredProps
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> (Bool -> Bool) -> Bool -> [()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Property -> Bool
D.propertyOptional Property
prop
        Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Property -> Text
argName Property
prop

    argName :: Property -> Text
argName = (Text
"arg_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
fieldNameHS Text
recName (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
D.propertyName

genRecordFromJson :: T.Text -> [D.Property] -> [T.Text]
genRecordFromJson :: Text -> [Property] -> [Text]
genRecordFromJson Text
recName [Property]
props =
    [Text
"instance FromJSON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
recName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ case [Property]
props of
        [] -> [Text
"parseJSON _ = pure " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
recName]
        [Property]
_  ->
            [Text
"parseJSON = A.withObject \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
recName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" $ \\o -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
recName] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
            ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
                (Bool
isFirst, Property
prop) <- [Property] -> [(Bool, Property)]
forall a. [a] -> [(Bool, a)]
markFirst [Property]
props
                Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
                    (if Bool
isFirst then Text
"<$>" else Text
"<*>") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
" o " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Property -> Bool
D.propertyOptional Property
prop then Text
"A..:?" else Text
"A..:") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
" \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
D.propertyName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""))

genRecordToJson :: T.Text -> [D.Property] -> [T.Text]
genRecordToJson :: Text -> [Property] -> [Text]
genRecordToJson Text
recName [Property]
params =
    [Text
"instance ToJSON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
recName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    (case [Property]
params of
        [] -> [Text
"  toJSON _ = A.Null"]
        [Property]
_  ->
            [Text
"  toJSON p = A.object $ catMaybes ["] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
            [
                Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
",\n    "
                [ Text
"(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
D.propertyName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" A..=) <$> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    (if Property -> Bool
D.propertyOptional Property
prop then Text
"" else Text
"Just ") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
fieldNameHS Text
recName (Property -> Text
D.propertyName Property
prop) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" p)"
                | Property
prop <- [Property]
params
                ]
            ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
            [Text
"    ]"])

propertyHsSig :: Context -> T.Text -> T.Text -> D.Property -> (T.Text, T.Text)
propertyHsSig :: Context -> Text -> Text -> Property -> (Text, Text)
propertyHsSig Context
ctx Text
domainName Text
recName Property
prop = case Property -> Maybe [Text]
D.propertyEnum Property
prop of
    Just [Text]
_  -> (Text
fn, (if Property -> Bool
D.propertyOptional Property
prop then Text
"Maybe " else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ftn)
    Maybe [Text]
Nothing -> (Text
fn, ) (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Context
-> Text -> Bool -> Maybe Text -> Maybe Text -> Maybe Items -> Text
genEltType Context
ctx Text
domainName (Property -> Bool
D.propertyOptional Property
prop)
        (Property -> Maybe Text
D.propertyType Property
prop)
        (Property -> Maybe Text
D.propertyRef Property
prop) 
        (Property -> Maybe Items
D.propertyItems Property
prop)
  where
    ftn :: Text
ftn = Text -> Text -> Text
tyNameHS Text
"" Text
fn
    fn :: Text
fn = Text -> Text -> Text
fieldNameHS Text
recName (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
D.propertyName (Property -> Text) -> Property -> Text
forall a b. (a -> b) -> a -> b
$ Property
prop

genTypeSynonynm :: Context -> T.Text -> T.Text -> T.Text
genTypeSynonynm :: Context -> Text -> Text -> Text
genTypeSynonynm Context
ctx Text
domainName Text
typeName = [Text] -> Text
T.unwords [Text
"type", Text
typeName, Text
"=", Context -> Text -> Text -> Maybe Items -> Text
typeCDPToHS Context
ctx Text
domainName Text
"object" Maybe Items
forall a. Maybe a
Nothing]

----------- Generation rules ----------- 
----- Docs    -----
formatComponentDescription :: Component -> T.Text
formatComponentDescription :: Component -> Text
formatComponentDescription Component
component = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [Text
"{- |"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    (do
        (Domain
delt, [Text]
_) <- Map Text (Domain, [Text]) -> [(Domain, [Text])]
forall k a. Map k a -> [a]
Map.elems (Map Text (Domain, [Text]) -> [(Domain, [Text])])
-> Map Text (Domain, [Text]) -> [(Domain, [Text])]
forall a b. (a -> b) -> a -> b
$ Component -> Map Text (Domain, [Text])
cDomDeps Component
component
        [Text
"= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Domain -> Text
domainName Domain
delt] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
""] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
            [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [Text]
T.lines (Domain -> Maybe Text
D.domainDescription Domain
delt)) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [Text
"-}"]

formatDescription :: Maybe T.Text -> [T.Text]
formatDescription :: Maybe Text -> [Text]
formatDescription = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Text -> Text -> [Text] -> [Text]
indentWith Text
"-- | " Text
"--   " ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines)


----- Imports -----
importDomain :: Bool -> T.Text -> T.Text 
importDomain :: Bool -> Text -> Text
importDomain Bool
as' Text
domainName = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ 
    if Bool
as' then [Text]
imp [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"as", Text
domainName] else [Text]
imp
  where
    imp :: [Text]
imp = [Text
"import", Text -> Text
domainModuleName Text
domainName]
   
componentToImport :: [ComponentName] -> [T.Text]
componentToImport :: [ComponentName] -> [Text]
componentToImport = (ComponentName -> Text) -> [ComponentName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (ComponentName -> Text) -> ComponentName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
domainModuleName (Text -> Text) -> (ComponentName -> Text) -> ComponentName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentName -> Text
unComponentName)

protocolModuleHeader :: [ComponentName] -> T.Text
protocolModuleHeader :: [ComponentName] -> Text
protocolModuleHeader [ComponentName]
names = [Text] -> Text
T.unlines
    [ Text
mod
    , Text
"( " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n, " [Text]
exports
    , Text
") where"
    ]
  where
    mod :: Text
mod = [Text] -> Text
T.unwords [ Text
"module", Text
protocolModuleName ]

    exports :: [Text]
exports = [ComponentName] -> [Text]
componentToImport [ComponentName]
names

protocolModuleName :: T.Text
protocolModuleName :: Text
protocolModuleName = Text
"CDP.Domains"

domainModuleHeader :: T.Text -> T.Text
domainModuleHeader :: Text -> Text
domainModuleHeader Text
domainName = [Text] -> Text
T.unwords [Text
"module", Text -> Text
domainModuleName Text
domainName, Text
"(module", Text -> Text
domainModuleName Text
domainName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
")", Text
"where"]

domainModuleName :: T.Text -> T.Text
domainModuleName :: Text -> Text
domainModuleName Text
domainName = Text -> [Text] -> Text
T.intercalate Text
"." [Text
"CDP", Text
"Domains", Text
domainName]

domainQualifiedName :: T.Text -> T.Text -> T.Text
domainQualifiedName :: Text -> Text -> Text
domainQualifiedName Text
domainName Text
n =  Text -> [Text] -> Text
T.intercalate Text
"." [Text
domainName, Text
n]

domainName :: D.Domain -> T.Text
domainName :: Domain -> Text
domainName = Domain -> Text
D.domainDomain

----- JSON -----

genFromJSONInstanceEnum :: T.Text -> [T.Text] -> [T.Text] -> [T.Text]
genFromJSONInstanceEnum :: Text -> [Text] -> [Text] -> [Text]
genFromJSONInstanceEnum Text
name [Text]
vals [Text]
hsVals =
    [Text
"instance FromJSON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
        [Text
"parseJSON = A.withText " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show) Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" $ \\v -> case v of"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
        ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
            (Text
v, Text
hsv) <- [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
vals ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"pure " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
hsVals) [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [Text -> (Text, Text)
emptyCase Text
name]
            Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (Text -> String
forall a. Show a => a -> String
show Text
v) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsv))

genToJSONInstanceEnum :: T.Text -> [T.Text] -> [T.Text] -> [T.Text]
genToJSONInstanceEnum :: Text -> [Text] -> [Text] -> [Text]
genToJSONInstanceEnum Text
name [Text]
vals [Text]
hsVals =
    [Text
"instance ToJSON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
        [Text
"toJSON v = A.String $ case v of"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
        ([Text] -> [Text]
indent ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
            (Text
v, Text
hsv) <- [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
vals [Text]
hsVals
            Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
hsv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Text -> String
forall a. Show a => a -> String
show Text
v)))

----- Types -----
genEltType :: Context -> T.Text -> Bool -> Maybe T.Text -> Maybe T.Text -> Maybe D.Items -> T.Text
genEltType :: Context
-> Text -> Bool -> Maybe Text -> Maybe Text -> Maybe Items -> Text
genEltType Context
ctx Text
name Bool
isOptional Maybe Text
t1 Maybe Text
t2 Maybe Items
items = (if Bool
isOptional then Text
"Maybe " else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Context -> Text -> Maybe Text -> Maybe Text -> Maybe Items -> Text
leftType Context
ctx Text
name Maybe Text
t1 Maybe Text
t2 Maybe Items
items)

leftType :: Context -> T.Text -> Maybe T.Text -> Maybe T.Text -> Maybe D.Items -> T.Text
leftType :: Context -> Text -> Maybe Text -> Maybe Text -> Maybe Items -> Text
leftType Context
ctx Text
_ (Just Text
ty1) (Just Text
ty2) Maybe Items
_ = String -> Text
forall a. HasCallStack => String -> a
error String
"impossible"
leftType Context
ctx Text
domain (Just Text
ty) Maybe Text
_ Maybe Items
itemsElt = Context -> Text -> Text -> Maybe Items -> Text
typeCDPToHS Context
ctx Text
domain Text
ty Maybe Items
itemsElt
leftType Context
ctx Text
domain Maybe Text
_ (Just Text
ty) Maybe Items
itemsElt = Context -> Text -> Text -> Maybe Items -> Text
typeCDPToHS Context
ctx Text
domain Text
ty Maybe Items
itemsElt
leftType Context
ctx Text
_ Maybe Text
_ Maybe Text
_ Maybe Items
_ = String -> Text
forall a. HasCallStack => String -> a
error String
"no type found"

typeCDPToHS :: Context -> T.Text -> T.Text -> Maybe D.Items -> T.Text
typeCDPToHS :: Context -> Text -> Text -> Maybe Items -> Text
typeCDPToHS Context
ctx Text
_ Text
"object" Maybe Items
_ = Text
"[(T.Text, T.Text)]"
typeCDPToHS Context
ctx Text
domain Text
"array" (Just Items
items) = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Context -> Text -> Maybe Text -> Maybe Text -> Maybe Items -> Text
leftType Context
ctx Text
domain (Items -> Maybe Text
D.itemsType Items
items) (Items -> Maybe Text
D.itemsRef Items
items) Maybe Items
forall a. Maybe a
Nothing) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
typeCDPToHS Context
ctx Text
_ Text
ty (Just Items
items) = String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"non-array type with items: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty
typeCDPToHS Context
ctx Text
domain Text
ty Maybe Items
Nothing = Context -> Text -> Text -> Text
convertType Context
ctx Text
domain Text
ty

convertType :: Context -> T.Text -> T.Text -> T.Text
convertType :: Context -> Text -> Text -> Text
convertType Context
_ Text
_ Text
"string"  = Text
"T.Text"
convertType Context
_ Text
_ Text
"integer" = Text
"Int"
convertType Context
_ Text
_ Text
"boolean" = Text
"Bool"
convertType Context
_ Text
_ Text
"number"  = Text
"Double"
convertType Context
_ Text
_ Text
"()" = Text
"()"
convertType Context
_ Text
_ Text
"any" = Text
"A.Value"
convertType Context
_ Text
_ Text
"array" = String -> Text
forall a. HasCallStack => String -> a
error String
"got array conversion"
convertType Context
_ Text
_ Text
"object" = String -> Text
forall a. HasCallStack => String -> a
error String
"got object type"
convertType Context
_ Text
_ Text
"" = String -> Text
forall a. HasCallStack => String -> a
error String
"got empty type"
convertType Context
ctx Text
domain Text
s = case Text -> Text -> [Text]
T.splitOn Text
"." Text
s of
    [Text
otherDomain, Text
ty] -> if Text -> Text
cn Text
otherDomain Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
cn Text
domain
            then Text -> Text -> Text
tyNameHS Text
otherDomain Text
ty -- both domains are in the same component, so the type is not qualified
            else Text -> Text -> Text
domainQualifiedName (Text -> Text
cn Text
otherDomain) (Text -> Text -> Text
tyNameHS Text
otherDomain Text
ty)
    [Text]
_ -> Text -> Text -> Text
tyNameHS Text
domain Text
s 
  where
    cn :: Text -> Text
cn Text
dn = ComponentName -> Text
unComponentName (ComponentName -> Text) -> (Text -> ComponentName) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Text -> ComponentName
domainToComponentName Context
ctx (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
dn

----- Dependencies -----    
{- : Domain dependencies specified in the protocol seem inaccurate:
    https://bugs.chromium.org/p/chromium/issues/detail?id=1354980#c0

    So they are collected by inspecting each domain.
-}

domainToComponentName :: Context -> T.Text -> ComponentName
domainToComponentName :: Context -> Text -> ComponentName
domainToComponentName Context
ctx Text
domainName = Component -> ComponentName
cName (Component -> ComponentName)
-> (Context -> Component) -> Context -> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DomainComponents -> Text -> Component)
-> Text -> DomainComponents -> Component
forall a b c. (a -> b -> c) -> b -> a -> c
flip DomainComponents -> Text -> Component
forall k a. Ord k => Map k a -> k -> a
(Map.!) Text
domainName) (DomainComponents -> Component)
-> (Context -> DomainComponents) -> Context -> Component
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> DomainComponents
ctxDomainComponents (Context -> ComponentName) -> Context -> ComponentName
forall a b. (a -> b) -> a -> b
$ Context
ctx 

newtype ComponentName = ComponentName { ComponentName -> Text
unComponentName :: T.Text }
    deriving (Int -> ComponentName -> ShowS
[ComponentName] -> ShowS
ComponentName -> String
(Int -> ComponentName -> ShowS)
-> (ComponentName -> String)
-> ([ComponentName] -> ShowS)
-> Show ComponentName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ComponentName] -> ShowS
$cshowList :: [ComponentName] -> ShowS
show :: ComponentName -> String
$cshow :: ComponentName -> String
showsPrec :: Int -> ComponentName -> ShowS
$cshowsPrec :: Int -> ComponentName -> ShowS
Show, ComponentName -> ComponentName -> Bool
(ComponentName -> ComponentName -> Bool)
-> (ComponentName -> ComponentName -> Bool) -> Eq ComponentName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ComponentName -> ComponentName -> Bool
$c/= :: ComponentName -> ComponentName -> Bool
== :: ComponentName -> ComponentName -> Bool
$c== :: ComponentName -> ComponentName -> Bool
Eq, Eq ComponentName
Eq ComponentName
-> (ComponentName -> ComponentName -> Ordering)
-> (ComponentName -> ComponentName -> Bool)
-> (ComponentName -> ComponentName -> Bool)
-> (ComponentName -> ComponentName -> Bool)
-> (ComponentName -> ComponentName -> Bool)
-> (ComponentName -> ComponentName -> ComponentName)
-> (ComponentName -> ComponentName -> ComponentName)
-> Ord ComponentName
ComponentName -> ComponentName -> Bool
ComponentName -> ComponentName -> Ordering
ComponentName -> ComponentName -> ComponentName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ComponentName -> ComponentName -> ComponentName
$cmin :: ComponentName -> ComponentName -> ComponentName
max :: ComponentName -> ComponentName -> ComponentName
$cmax :: ComponentName -> ComponentName -> ComponentName
>= :: ComponentName -> ComponentName -> Bool
$c>= :: ComponentName -> ComponentName -> Bool
> :: ComponentName -> ComponentName -> Bool
$c> :: ComponentName -> ComponentName -> Bool
<= :: ComponentName -> ComponentName -> Bool
$c<= :: ComponentName -> ComponentName -> Bool
< :: ComponentName -> ComponentName -> Bool
$c< :: ComponentName -> ComponentName -> Bool
compare :: ComponentName -> ComponentName -> Ordering
$ccompare :: ComponentName -> ComponentName -> Ordering
$cp1Ord :: Eq ComponentName
Ord)

type DomainDependencies = Map.Map T.Text (D.Domain, [T.Text])
data Component = Component {
  Component -> ComponentName
cName     :: ComponentName
, Component -> Map Text (Domain, [Text])
cDomDeps  :: DomainDependencies
}

type DomainComponents = Map.Map T.Text Component
    -- original domain name, component the domain belongs to
    -- domain name for each vertex is the modified domain name
type Vertex = (D.Domain, T.Text, [T.Text]) -- domain, domain name, domain dependencies 

domainComponents :: [D.Domain] -> DomainComponents
domainComponents :: [Domain] -> DomainComponents
domainComponents [Domain]
delts = [(Text, Component)] -> DomainComponents
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Component)] -> DomainComponents)
-> ([[Vertex]] -> [(Text, Component)])
-> [[Vertex]]
-> DomainComponents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Vertex] -> [(Text, Component)])
-> [[Vertex]] -> [(Text, Component)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Vertex] -> [(Text, Component)]
verticesToDomainComponents ([[Vertex]] -> DomainComponents) -> [[Vertex]] -> DomainComponents
forall a b. (a -> b) -> a -> b
$ [[Vertex]]
vsc2
  where
    vsc2 :: [[Vertex]]
vsc2  = ([Vertex] -> [Vertex]) -> [[Vertex]] -> [[Vertex]]
forall a b. (a -> b) -> [a] -> [b]
map [Vertex] -> [Vertex]
removeSameComponentDependencies [[Vertex]]
vsc1   
    vsc1 :: [[Vertex]]
vsc1  = (SCC Vertex -> [Vertex]) -> [SCC Vertex] -> [[Vertex]]
forall a b. (a -> b) -> [a] -> [b]
map SCC Vertex -> [Vertex]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC ([SCC Vertex] -> [[Vertex]])
-> ([Vertex] -> [SCC Vertex]) -> [Vertex] -> [[Vertex]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vertex] -> [SCC Vertex]
forall key node.
Ord key =>
[(node, key, [key])] -> [SCC (node, key, [key])]
Graph.stronglyConnCompR ([Vertex] -> [[Vertex]]) -> [Vertex] -> [[Vertex]]
forall a b. (a -> b) -> a -> b
$ [Vertex]
g
    g :: [Vertex]
g     = (Domain -> Vertex) -> [Domain] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (\Domain
delt -> (Domain
delt, Domain -> Text
domainName Domain
delt, Domain -> [Text]
deps Domain
delt)) [Domain]
delts
    deps :: Domain -> [Text]
deps  = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> (Domain -> Set Text) -> Domain -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Set Text
domainDependencies

verticesToDomainComponents :: [Vertex] -> [(T.Text, Component)]
verticesToDomainComponents :: [Vertex] -> [(Text, Component)]
verticesToDomainComponents [Vertex]
vs = (Text -> (Text, Component)) -> [Text] -> [(Text, Component)]
forall a b. (a -> b) -> [a] -> [b]
map (,Component
c) [Text]
dns
  where
    dns :: [Text]
dns = (Vertex -> Text) -> [Vertex] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Text
vertexToDomainName [Vertex]
vs 
    c :: Component
c   = [Vertex] -> Component
verticesToComponent [Vertex]
vs

vertexToDomainName :: Vertex -> T.Text
vertexToDomainName :: Vertex -> Text
vertexToDomainName (Domain
_,Text
dn,[Text]
_) = Text
dn 

verticesToComponent :: [Vertex] -> Component
verticesToComponent :: [Vertex] -> Component
verticesToComponent [Vertex]
vs = ComponentName -> Map Text (Domain, [Text]) -> Component
Component ComponentName
cn (Map Text (Domain, [Text]) -> Component)
-> ([Vertex] -> Map Text (Domain, [Text])) -> [Vertex] -> Component
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, (Domain, [Text]))] -> Map Text (Domain, [Text])
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, (Domain, [Text]))] -> Map Text (Domain, [Text]))
-> ([Vertex] -> [(Text, (Domain, [Text]))])
-> [Vertex]
-> Map Text (Domain, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex -> (Text, (Domain, [Text])))
-> [Vertex] -> [(Text, (Domain, [Text]))]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> (Text, (Domain, [Text]))
forall a a b. (a, a, b) -> (a, (a, b))
toComponent ([Vertex] -> Component) -> [Vertex] -> Component
forall a b. (a -> b) -> a -> b
$ [Vertex]
vs
  where
    toComponent :: (a, a, b) -> (a, (a, b))
toComponent (a
delt,a
dn,b
deps) = (a
dn, (a
delt, b
deps))
    cn :: ComponentName
cn = [Vertex] -> ComponentName
componentName [Vertex]
vs

componentName :: [Vertex] -> ComponentName
componentName :: [Vertex] -> ComponentName
componentName [Vertex
v] = Text -> ComponentName
ComponentName (Text -> ComponentName) -> Text -> ComponentName
forall a b. (a -> b) -> a -> b
$ Vertex -> Text
vertexToDomainName Vertex
v 
componentName [Vertex]
vs  = Text -> ComponentName
ComponentName (Text -> ComponentName) -> Text -> ComponentName
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Vertex] -> [Text]) -> [Vertex] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex -> Text) -> [Vertex] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Text
vertexToDomainName ([Vertex] -> Text) -> [Vertex] -> Text
forall a b. (a -> b) -> a -> b
$ [Vertex]
vs

removeSameComponentDependencies :: [Vertex] -> [Vertex]
removeSameComponentDependencies :: [Vertex] -> [Vertex]
removeSameComponentDependencies [Vertex]
vs = (Vertex -> Vertex) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map ([Vertex] -> Vertex -> Vertex
forall p t t. p -> (t, t, [Text]) -> (t, t, [Text])
go [Vertex]
vs) [Vertex]
vs
  where
    go :: p -> (t, t, [Text]) -> (t, t, [Text])
go p
vs (t
delt, t
dn, [Text]
deps) = (t
delt,t
dn,) ([Text] -> (t, t, [Text]))
-> (Set Text -> [Text]) -> Set Text -> (t, t, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> (t, t, [Text])) -> Set Text -> (t, t, [Text])
forall a b. (a -> b) -> a -> b
$ 
        ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
deps) Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Text
dns
    dns :: Set Text
dns = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (Vertex -> Text) -> [Vertex] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Text
vertexToDomainName [Vertex]
vs

domainDependencies :: D.Domain -> Set.Set T.Text
domainDependencies :: Domain -> Set Text
domainDependencies Domain
delt = Set Text -> Set Text
removeSelf (Set Text -> Set Text)
-> ([[Text]] -> Set Text) -> [[Text]] -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text)
-> ([[Text]] -> [Text]) -> [[Text]] -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> Set Text) -> [[Text]] -> Set Text
forall a b. (a -> b) -> a -> b
$
    [ (Type -> [Text]) -> [Type] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Text]
typeDependencies    ([Type] -> [Text]) -> [Type] -> [Text]
forall a b. (a -> b) -> a -> b
$ Domain -> [Type]
D.domainTypes Domain
delt
    , (Command -> [Text]) -> [Command] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Command -> [Text]
commandDependencies ([Command] -> [Text]) -> [Command] -> [Text]
forall a b. (a -> b) -> a -> b
$ Domain -> [Command]
D.domainCommands Domain
delt
    , (Event -> [Text]) -> [Event] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Event -> [Text]
eventDependencies   ([Event] -> [Text]) -> [Event] -> [Text]
forall a b. (a -> b) -> a -> b
$ Domain -> [Event]
D.domainEvents Domain
delt
    ]
  where
    removeSelf :: Set Text -> Set Text
removeSelf = (Text -> Bool) -> Set Text -> Set Text
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
dn)
    dn :: Text
dn = Domain -> Text
domainName Domain
delt

typeDependencies :: D.Type -> [T.Text]
typeDependencies :: Type -> [Text]
typeDependencies Type
telt = case Type -> Maybe [Text]
D.typeEnum Type
telt of 
    Just [Text]
_  -> []
    Maybe [Text]
Nothing -> case Type -> Text
D.typeType Type
telt of
        Text
"array"  -> [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> [Text])
-> (Maybe (Maybe Text) -> Maybe Text)
-> Maybe (Maybe Text)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Text) -> [Text]) -> Maybe (Maybe Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ Items -> Maybe Text
itemDependencies (Items -> Maybe Text) -> Maybe Items -> Maybe (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Items
D.typeItems Type
telt
        Text
"object" -> [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text])
-> ([Property] -> [Maybe Text]) -> [Property] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Property -> Maybe Text) -> [Property] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Maybe Text
propertyDependencies ([Property] -> [Text]) -> Maybe [Property] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [Property]
D.typeProperties Type
telt
        Text
s -> [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> [Text]) -> Maybe Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
refTypeToDomain Text
s

commandDependencies :: D.Command -> [T.Text]
commandDependencies :: Command -> [Text]
commandDependencies Command
celt = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text])
-> ([Property] -> [Maybe Text]) -> [Property] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Property -> Maybe Text) -> [Property] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Maybe Text
propertyDependencies ([Property] -> [Text]) -> [Property] -> [Text]
forall a b. (a -> b) -> a -> b
$ Command -> [Property]
D.commandReturns Command
celt
    , [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text])
-> ([Property] -> [Maybe Text]) -> [Property] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Property -> Maybe Text) -> [Property] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Maybe Text
propertyDependencies ([Property] -> [Text]) -> [Property] -> [Text]
forall a b. (a -> b) -> a -> b
$ Command -> [Property]
D.commandParameters Command
celt
    ]

eventDependencies :: D.Event -> [T.Text]
eventDependencies :: Event -> [Text]
eventDependencies Event
evelt =
    [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text])
-> ([Property] -> [Maybe Text]) -> [Property] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Property -> Maybe Text) -> [Property] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Maybe Text
propertyDependencies ([Property] -> [Text]) -> [Property] -> [Text]
forall a b. (a -> b) -> a -> b
$ Event -> [Property]
D.eventParameters Event
evelt

propertyDependencies :: D.Property -> Maybe T.Text
propertyDependencies :: Property -> Maybe Text
propertyDependencies Property
pelt = case Property -> Maybe [Text]
D.propertyEnum Property
pelt of
        Just [Text]
_  -> Maybe Text
forall a. Maybe a
Nothing
        Maybe [Text]
Nothing -> case Property -> Maybe Text
D.propertyRef Property
pelt of
            Just Text
r  -> Text -> Maybe Text
refTypeToDomain Text
r
            Maybe Text
Nothing -> case Property -> Maybe Text
D.propertyType Property
pelt of
                Just Text
"object" -> Maybe Text
forall a. Maybe a
Nothing
                Just Text
"array"  -> Items -> Maybe Text
itemDependencies (Items -> Maybe Text) -> Maybe Items -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Property -> Maybe Items
D.propertyItems Property
pelt
                Just Text
s -> Text -> Maybe Text
refTypeToDomain Text
s
                Maybe Text
_      -> Maybe Text
forall a. Maybe a
Nothing

itemDependencies :: D.Items -> Maybe T.Text
itemDependencies :: Items -> Maybe Text
itemDependencies Items
itelt = Text -> Maybe Text
refTypeToDomain (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Items -> Maybe Text
D.itemsRef Items
itelt

----- Names -----
eventName   :: T.Text -> D.Event -> T.Text
eventName :: Text -> Event -> Text
eventName   Text
domainName Event
ev = (Text
domainName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Event -> Text) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Event -> Text) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Text
D.eventName (Event -> Text) -> Event -> Text
forall a b. (a -> b) -> a -> b
$ Event
ev
eventNameHS :: T.Text -> D.Event -> T.Text
eventNameHS :: Text -> Event -> Text
eventNameHS Text
domainName Event
ev = Text -> Text -> Text
tyNameHS Text
domainName (Event -> Text
D.eventName Event
ev)

commandName   :: T.Text -> D.Command -> T.Text
commandName :: Text -> Command -> Text
commandName Text
domainName Command
c = (Text
domainName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Command -> Text) -> Command -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Command -> Text) -> Command -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> Text
D.commandName (Command -> Text) -> Command -> Text
forall a b. (a -> b) -> a -> b
$ Command
c
commandNameHS :: T.Text -> D.Command -> T.Text
commandNameHS :: Text -> Command -> Text
commandNameHS Text
domainName Command
c = Text -> Text -> Text
tyNameHS Text
domainName (Command -> Text
D.commandName Command
c)
commandParamsNameHS :: T.Text -> D.Command -> T.Text
commandParamsNameHS :: Text -> Command -> Text
commandParamsNameHS Text
domainName Command
c = Text -> Text
paramsTypePrefix (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Command -> Text
commandNameHS Text
domainName Command
c

typeNameHS :: T.Text -> D.Type -> T.Text
typeNameHS :: Text -> Type -> Text
typeNameHS Text
domainName Type
t = Text -> Text -> Text
tyNameHS Text
domainName (Type -> Text
D.typeId Type
t)

tyNameHS :: T.Text -> T.Text -> T.Text
tyNameHS :: Text -> Text -> Text
tyNameHS Text
prefix Text
tyName =
    Text -> Text
capitalizeFirst Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalizeFirst (Text -> Text
hyphensToCapitalize Text
tyName)

fieldNameHS :: T.Text -> T.Text -> T.Text
fieldNameHS :: Text -> Text -> Text
fieldNameHS Text
tyName Text
fieldName = Text -> Text
uncapitalizeFirst Text
tyName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalizeFirst Text
fieldName

paramsTypePrefix :: T.Text -> T.Text
paramsTypePrefix :: Text -> Text
paramsTypePrefix = (Text
"P" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

refTypeToDomain :: T.Text -> Maybe T.Text
refTypeToDomain :: Text -> Maybe Text
refTypeToDomain Text
r = case Text -> Text -> [Text]
T.splitOn Text
"." Text
r of
    [Text
domain, Text
_] -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
domain
    [Text]
_           -> Maybe Text
forall a. Maybe a
Nothing

-----
emptyCase :: T.Text -> (T.Text, T.Text)
emptyCase :: Text -> (Text, Text)
emptyCase Text
name = (Text
"_", [Text] -> Text
T.unwords [Text
"fail", (String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"failed to parse " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name])

derivingBase    :: T.Text
derivingBase :: Text
derivingBase    = Text
"deriving (Eq, Show, Read)"
derivingOrd     :: T.Text
derivingOrd :: Text
derivingOrd     = Text
"deriving (Ord, Eq, Show, Read)"

-----------  Utilities ----------- 

indent :: [T.Text] -> [T.Text]
indent :: [Text] -> [Text]
indent = Text -> Text -> [Text] -> [Text]
indentWith Text
"  " Text
"  "

indentWith :: T.Text -> T.Text -> [T.Text] -> [T.Text]
indentWith :: Text -> Text -> [Text] -> [Text]
indentWith Text
_         Text
_          []       = []
indentWith Text
firstLine Text
otherLines (Text
x : [Text]
xs) =
    (Text
firstLine Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
otherLines Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
xs

capitalizeFirst :: T.Text -> T.Text
capitalizeFirst :: Text -> Text
capitalizeFirst Text
t = Text -> ((Char, Text) -> Text) -> Maybe (Char, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
t (\(Char
first, Text
rest) -> Char -> Text
T.singleton (Char -> Char
toUpper Char
first) Text -> Text -> Text
`T.append` Text
rest) (Maybe (Char, Text) -> Text)
-> (Text -> Maybe (Char, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
T.uncons (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
t

uncapitalizeFirst :: T.Text -> T.Text
uncapitalizeFirst :: Text -> Text
uncapitalizeFirst Text
t = Text -> ((Char, Text) -> Text) -> Maybe (Char, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
t (\(Char
first, Text
rest) -> Char -> Text
T.singleton (Char -> Char
toLower Char
first) Text -> Text -> Text
`T.append` Text
rest) (Maybe (Char, Text) -> Text)
-> (Text -> Maybe (Char, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
T.uncons (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
t

markFirst :: [a] -> [(Bool, a)]
markFirst :: [a] -> [(Bool, a)]
markFirst = [Bool] -> [a] -> [(Bool, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False)

markLast :: [a] -> [(Bool, a)]
markLast :: [a] -> [(Bool, a)]
markLast []          = []
markLast (a
x : [])    = [(Bool
True, a
x)]
markLast (a
x : a
y : [a]
z) = (Bool
False, a
x) (Bool, a) -> [(Bool, a)] -> [(Bool, a)]
forall a. a -> [a] -> [a]
: [a] -> [(Bool, a)]
forall a. [a] -> [(Bool, a)]
markLast (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
z)

-- | Changes things like "a-rate" to "aRate"
hyphensToCapitalize :: T.Text -> T.Text
hyphensToCapitalize :: Text -> Text
hyphensToCapitalize Text
txt
    | Text -> Bool
T.null Text
after = Text
before
    | Bool
otherwise    =
        Text
before Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalizeFirst (Text -> Text
hyphensToCapitalize (Int -> Text -> Text
T.drop Int
1 Text
after))
  where
    (Text
before, Text
after) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Text
txt