{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
module Netw.Internal.Port where
import Netw.Internal.Type

import Data.List
import Data.Char
import qualified Data.List.NonEmpty as N

import Data.Word
import Language.Haskell.TH


declarePorts :: Name -> DecsQ
declarePorts :: Name -> DecsQ
declarePorts Name
constructor =
  -- runIO (print . grpOnNameAndPort =<< servents) >> return []
  IO [Servent] -> Q [Servent]
forall a. IO a -> Q a
runIO IO [Servent]
servents Q [Servent] -> ([Servent] -> DecsQ) -> DecsQ
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(String, Word16)] -> DecsQ
emit ([(String, Word16)] -> DecsQ)
-> ([Servent] -> [(String, Word16)]) -> [Servent] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, NonEmpty (Word16, NonEmpty String))
 -> [(String, Word16)])
-> [(String, NonEmpty (Word16, NonEmpty String))]
-> [(String, Word16)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, NonEmpty (Word16, NonEmpty String)) -> [(String, Word16)]
service ([(String, NonEmpty (Word16, NonEmpty String))]
 -> [(String, Word16)])
-> ([Servent] -> [(String, NonEmpty (Word16, NonEmpty String))])
-> [Servent]
-> [(String, Word16)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Servent] -> [(String, NonEmpty (Word16, NonEmpty String))]
grpOnNameAndPort
  where emit :: [(String, Word16)] -> DecsQ
        emit :: [(String, Word16)] -> DecsQ
emit (((String, Word16) -> String)
-> [(String, Word16)] -> [(String, Word16)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String, Word16) -> String
forall a b. (a, b) -> a
fst -> [(String, Word16)]
ports) =
          let grp1 :: t -> [(t, b)] -> ([(t, b)], [(t, b)])
grp1 t
name ((t, b)
a:[(t, b)]
as)
                | t
name t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== (t, b) -> t
forall a b. (a, b) -> a
fst (t, b)
a = ((t, b)
a:) ([(t, b)] -> [(t, b)])
-> ([(t, b)], [(t, b)]) -> ([(t, b)], [(t, b)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> [(t, b)] -> ([(t, b)], [(t, b)])
grp1 t
name [(t, b)]
as
                | Bool
otherwise     = ((t, b)
a(t, b) -> [(t, b)] -> [(t, b)]
forall a. a -> [a] -> [a]
:[(t, b)]
as,[])
              grp1 t
_    [] = ([], [])
              grp2 :: [(t, b)] -> [NonEmpty (t, b)]
grp2 ((t, b)
a:[(t, b)]
as) =
                let ([(t, b)]
as', [(t, b)]
p) = t -> [(t, b)] -> ([(t, b)], [(t, b)])
forall {t} {b}. Eq t => t -> [(t, b)] -> ([(t, b)], [(t, b)])
grp1 ((t, b) -> t
forall a b. (a, b) -> a
fst (t, b)
a) [(t, b)]
as
                in  ((t, b)
a (t, b) -> [(t, b)] -> NonEmpty (t, b)
forall a. a -> [a] -> NonEmpty a
N.:| [(t, b)]
p)NonEmpty (t, b) -> [NonEmpty (t, b)] -> [NonEmpty (t, b)]
forall a. a -> [a] -> [a]
:[(t, b)] -> [NonEmpty (t, b)]
grp2 [(t, b)]
as'
              grp2 []     = []
              list :: [(String, Word16)]
list =
                let f :: NonEmpty (String, b) -> [(String, b)]
f ((String, b)
a N.:| [(String, b)]
as)
                      | [(String, b)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, b)]
as   = [(String, b)
a]
                      | Bool
otherwise = ((String, b) -> (String, b)) -> [(String, b)] -> [(String, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (String
name, b
port) -> (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: b -> String
forall a. Show a => a -> String
show b
port, b
port)) ((String, b)
a(String, b) -> [(String, b)] -> [(String, b)]
forall a. a -> [a] -> [a]
:[(String, b)]
as)
                in  (NonEmpty (String, Word16) -> [(String, Word16)])
-> [NonEmpty (String, Word16)] -> [(String, Word16)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (String, Word16) -> [(String, Word16)]
forall {b}. Show b => NonEmpty (String, b) -> [(String, b)]
f ([(String, Word16)] -> [NonEmpty (String, Word16)]
forall {t} {b}. Eq t => [(t, b)] -> [NonEmpty (t, b)]
grp2 [(String, Word16)]
ports)
        --  in  runIO (print list) >> return []
          in  [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD (String -> Name
mkName String
name)
                                 ([Name] -> Q PatSynArgs
forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prefixPatSyn [])
                                 Q PatSynDir
forall (m :: * -> *). Quote m => m PatSynDir
implBidir
                                 (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
constructor [Word16 -> Q Pat
w16ToLit Word16
port])
                       | (String
name, Word16
port) <- [(String, Word16)]
list ]
        service :: (String, N.NonEmpty (Word16, N.NonEmpty String)) -> [(String, Word16)]
        service :: (String, NonEmpty (Word16, NonEmpty String)) -> [(String, Word16)]
service (String
name, (Word16, NonEmpty String)
pp N.:| [(Word16, NonEmpty String)]
pps)
          | [(Word16, NonEmpty String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Word16, NonEmpty String)]
pps  = [(String
"IPPORT_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalize String
name, (Word16, NonEmpty String) -> Word16
forall a b. (a, b) -> a
fst (Word16, NonEmpty String)
pp)]
          | Bool
otherwise = [[(String, Word16)]] -> [(String, Word16)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ 
              [ (String
"IPPORT_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalize String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
normalize String
proto, Word16
port)
              | String
proto <- NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
N.toList NonEmpty String
protos]
            | (Word16
port, NonEmpty String
protos) <- (Word16, NonEmpty String)
pp(Word16, NonEmpty String)
-> [(Word16, NonEmpty String)] -> [(Word16, NonEmpty String)]
forall a. a -> [a] -> [a]
:[(Word16, NonEmpty String)]
pps]
        w16ToLit :: Word16 -> Q Pat
w16ToLit = Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Lit -> Q Pat) -> (Word16 -> Lit) -> Word16 -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Word16 -> Integer) -> Word16 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        stage1 :: [Servent] -> [(String, N.NonEmpty (Word16, String))]
        stage1 :: [Servent] -> [(String, NonEmpty (Word16, String))]
stage1 ((Servent -> String) -> [Servent] -> [Servent]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Servent -> String
sName -> [Servent]
db) =
          let grp1 :: String -> [Servent] -> ([Servent], [(Word16, String)])
grp1 String
name (e :: Servent
e@(Servent -> String
sName -> String
name'):[Servent]
es)
                | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name' = ((Servent -> Word16
sPort Servent
e, Servent -> String
sProto Servent
e):) ([(Word16, String)] -> [(Word16, String)])
-> ([Servent], [(Word16, String)])
-> ([Servent], [(Word16, String)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Servent] -> ([Servent], [(Word16, String)])
grp1 String
name [Servent]
es
                | Bool
otherwise     = (Servent
eServent -> [Servent] -> [Servent]
forall a. a -> [a] -> [a]
:[Servent]
es, [])
              grp1 String
_ [] = ([], [])
              grp2 :: [Servent] -> [(String, NonEmpty (Word16, String))]
grp2 (e :: Servent
e@(Servent -> String
sName -> String
name):[Servent]
es) = 
                let ([Servent]
es', [(Word16, String)]
ports) = String -> [Servent] -> ([Servent], [(Word16, String)])
grp1 String
name [Servent]
es
                in  (String
name, (Servent -> Word16
sPort Servent
e, Servent -> String
sProto Servent
e) (Word16, String) -> [(Word16, String)] -> NonEmpty (Word16, String)
forall a. a -> [a] -> NonEmpty a
N.:| [(Word16, String)]
ports)(String, NonEmpty (Word16, String))
-> [(String, NonEmpty (Word16, String))]
-> [(String, NonEmpty (Word16, String))]
forall a. a -> [a] -> [a]
:[Servent] -> [(String, NonEmpty (Word16, String))]
grp2 [Servent]
es'
              grp2 [] = []
          in  [Servent] -> [(String, NonEmpty (Word16, String))]
grp2 [Servent]
db
        stage2 :: [(String, N.NonEmpty (Word16, String))] -> [(String, N.NonEmpty (Word16, N.NonEmpty String))]
        stage2 :: [(String, NonEmpty (Word16, String))]
-> [(String, NonEmpty (Word16, NonEmpty String))]
stage2 = 
          ((String, NonEmpty (Word16, String))
 -> (String, NonEmpty (Word16, NonEmpty String)))
-> [(String, NonEmpty (Word16, String))]
-> [(String, NonEmpty (Word16, NonEmpty String))]
forall a b. (a -> b) -> [a] -> [b]
map (((String, NonEmpty (Word16, String))
  -> (String, NonEmpty (Word16, NonEmpty String)))
 -> [(String, NonEmpty (Word16, String))]
 -> [(String, NonEmpty (Word16, NonEmpty String))])
-> ((String, NonEmpty (Word16, String))
    -> (String, NonEmpty (Word16, NonEmpty String)))
-> [(String, NonEmpty (Word16, String))]
-> [(String, NonEmpty (Word16, NonEmpty String))]
forall a b. (a -> b) -> a -> b
$ 
          \ (String
serviceName, ((Word16, String) -> Word16)
-> NonEmpty (Word16, String) -> NonEmpty (Word16, String)
forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
N.sortWith (Word16, String) -> Word16
forall a b. (a, b) -> a
fst -> NonEmpty (Word16, String)
portProt) -> 
            let grp1 :: t -> [(t, a)] -> ([(t, a)], [a])
grp1 t
port (pp :: (t, a)
pp@(t
port', a
proto):[(t, a)]
pps)
                  | t
port t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
port' = (a
proto:) ([a] -> [a]) -> ([(t, a)], [a]) -> ([(t, a)], [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> [(t, a)] -> ([(t, a)], [a])
grp1 t
port [(t, a)]
pps
                  | Bool
otherwise     = ((t, a)
pp(t, a) -> [(t, a)] -> [(t, a)]
forall a. a -> [a] -> [a]
:[(t, a)]
pps, [])
                grp1 t
_    [] = ([], [])
                grp2 :: [(a, a)] -> [(a, NonEmpty a)]
grp2 ((a
port, a
proto):[(a, a)]
pps) =
                  let ([(a, a)]
pps', [a]
protos) = a -> [(a, a)] -> ([(a, a)], [a])
forall {t} {a}. Eq t => t -> [(t, a)] -> ([(t, a)], [a])
grp1 a
port [(a, a)]
pps
                  in  (a
port, a
proto a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
N.:| [a]
protos)(a, NonEmpty a) -> [(a, NonEmpty a)] -> [(a, NonEmpty a)]
forall a. a -> [a] -> [a]
:[(a, a)] -> [(a, NonEmpty a)]
grp2 [(a, a)]
pps'
                grp2 [] = []
                grp3 :: NonEmpty (a, a) -> NonEmpty (a, NonEmpty a)
grp3 ((a
port, a
proto) N.:| [(a, a)]
pps) =
                  let ([(a, a)]
pps', [a]
protos) = a -> [(a, a)] -> ([(a, a)], [a])
forall {t} {a}. Eq t => t -> [(t, a)] -> ([(t, a)], [a])
grp1 a
port [(a, a)]
pps
                  in  (a
port, a
proto a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
N.:| [a]
protos) (a, NonEmpty a) -> [(a, NonEmpty a)] -> NonEmpty (a, NonEmpty a)
forall a. a -> [a] -> NonEmpty a
N.:| [(a, a)] -> [(a, NonEmpty a)]
forall {a} {a}. Eq a => [(a, a)] -> [(a, NonEmpty a)]
grp2 [(a, a)]
pps'
            in  (String
serviceName, NonEmpty (Word16, String) -> NonEmpty (Word16, NonEmpty String)
forall {a} {a}. Eq a => NonEmpty (a, a) -> NonEmpty (a, NonEmpty a)
grp3 NonEmpty (Word16, String)
portProt)
        grpOnNameAndPort :: [Servent] -> [(String, N.NonEmpty (Word16, N.NonEmpty String))]
        grpOnNameAndPort :: [Servent] -> [(String, NonEmpty (Word16, NonEmpty String))]
grpOnNameAndPort = [(String, NonEmpty (Word16, String))]
-> [(String, NonEmpty (Word16, NonEmpty String))]
stage2 ([(String, NonEmpty (Word16, String))]
 -> [(String, NonEmpty (Word16, NonEmpty String))])
-> ([Servent] -> [(String, NonEmpty (Word16, String))])
-> [Servent]
-> [(String, NonEmpty (Word16, NonEmpty String))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Servent] -> [(String, NonEmpty (Word16, String))]
stage1
        normalize :: String -> String
normalize = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String)
-> (Char -> Char) -> String -> String
forall a b. (a -> b) -> a -> b
$ (\case Char
'-' -> Char
'_'; Char
other -> Char
other) (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toUpper