123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225 |
- module Gidl.Backend.Tower.Server where
- import Data.Monoid
- import Data.List (intercalate, nub)
- import Gidl.Interface
- import Gidl.Schema
- import Gidl.Backend.Ivory.Types
- import Gidl.Backend.Ivory.Schema (ifModuleName)
- import Ivory.Artifact
- import Text.PrettyPrint.Mainland
- umbrellaModule :: [String] -> Interface -> Artifact
- umbrellaModule modulepath i =
- artifactPath (intercalate "/" modulepath) $
- artifactText (ifModuleName i ++ ".hs") $
- prettyLazyText 80 $
- stack
- [ text "module" <+> mname
- , indent 2 $ encloseStack lparen (rparen <+> text "where") comma
- [ text "module" <+> im "Producer"
- , text "module" <+> im "Consumer"
- , text "module" <+> im "Server"
- ]
- , text "import" <+> im "Producer"
- , text "import" <+> im "Consumer"
- , text "import" <+> im "Server"
- ]
- where
- modAt path = mconcat (punctuate dot (map text path))
- mname = modAt (modulepath ++ [ifModuleName i])
- im m = modAt (modulepath ++ [ifModuleName i, m])
- serverModule :: [String] -> Interface -> Artifact
- serverModule modulepath i =
- artifactPath (intercalate "/" (modulepath ++ [ifModuleName i])) $
- artifactText "Server.hs" $
- prettyLazyText 80 $
- stack
- [ text "{-# LANGUAGE DataKinds #-}"
- , text "{-# LANGUAGE RankNTypes #-}"
- , text "{-# LANGUAGE ScopedTypeVariables #-}"
- , text "{-# LANGUAGE KindSignatures #-}"
- , text "{-# LANGUAGE RecordWildCards #-}"
- , text "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
- , text "{-# OPTIONS_GHC -fno-warn-unused-matches #-}"
- , empty
- , text "module"
- <+> im "Server"
- <+> text "where"
- , empty
- , stack imports
- , empty
- , attrsDataType i
- , empty
- , attrsTowerConstructor i
- , empty
- , attrsInitializer i
- , empty
- , streamsDataType i
- , empty
- , streamsTowerConstructor i
- , empty
- , interfaceServer i
- ]
- where
- rootpath = reverse . drop 2 . reverse
- modAt path = mconcat (punctuate dot (map text path))
- im mname = modAt (modulepath ++ [ifModuleName i, mname])
- tm mname = modAt (rootpath modulepath ++ ["Ivory","Types", mname])
- imports =
- [ text "import" <+> modAt (rootpath modulepath ++ ["Tower", "Attr"])
- , text "import" <+> im "Producer"
- , text "import" <+> im "Consumer"
- , text "import Ivory.Language"
- , text "import Ivory.Tower"
- ] ++ typeimports
- typeimports = map (importDecl tm)
- $ nub
- $ map importType
- $ interfaceTypes i
- attrsDataType :: Interface -> Doc
- attrsDataType i = text "data" <+> constructor <+> text "(p :: Area * -> *) ="
- </> indent 2 constructor
- </> indent 4 body
- where
- constructor = text (ifModuleName i) <> text "Attrs"
- body = encloseStack lbrace rbrace comma
- [ text n <+> colon <> colon <+> text "p"
- <+> typeIvoryArea t
- | (aname, AttrMethod _ t) <- interfaceMethods i
- , let n = userEnumValueName aname
- ]
- attrsTowerConstructor :: Interface -> Doc
- attrsTowerConstructor i = typesig </> decl </> indent 2 body </> indent 2 ret
- where
- constructor = text (ifModuleName i) <> text "Attrs"
- typesig = text "tower" <> constructor <+> colon <> colon
- <+> constructor <+> text "Init"
- <+> text "->"
- <+> text "Tower e" <+> parens (constructor <+> text "Attr")
- decl = text "tower" <> constructor <+> text "ivals = do"
- body = stack
- [ text n <> text "_p <- towerAttr"
- <+> dquotes (text aname)
- <+> parens (text n <+> text "ivals")
- | (aname, AttrMethod _ _) <- interfaceMethods i
- , let n = userEnumValueName aname
- ]
- ret = text "return" <+> constructor <+> encloseStack lbrace rbrace comma
- [ text n <+> equals <+> text n <> text "_p"
- | (aname, AttrMethod _ _) <- interfaceMethods i
- , let n = userEnumValueName aname
- ]
- attrsInitializer :: Interface -> Doc
- attrsInitializer i = typesig </> decl </> indent 2 body
- where
- constructor = text (ifModuleName i) <> text "Attrs"
- typesig = text "init" <> constructor <+> colon <> colon
- <+> constructor <+> text "Init"
- decl = text "init" <> constructor <+> equals <+> constructor
- body = encloseStack lbrace rbrace comma
- [ text n <+> equals <+> text "izero"
- | (aname, AttrMethod _ _) <- interfaceMethods i
- , let n = userEnumValueName aname
- ]
- streamsDataType :: Interface -> Doc
- streamsDataType i = text "data" <+> constructor <+> text "(p :: Area * -> *) ="
- </> indent 2 constructor
- </> indent 4 body
- where
- constructor = text (ifModuleName i) <> text "Streams"
- body = encloseStack lbrace rbrace comma
- [ text n <+> colon <> colon <+> text "p"
- <+> parens (text (typeIvoryType t))
- | (aname, StreamMethod _ t) <- interfaceMethods i
- , let n = userEnumValueName aname
- ]
- streamsTowerConstructor :: Interface -> Doc
- streamsTowerConstructor i = typesig </> decl </> indent 2 body </> indent 2 ret
- where
- constructor = text (ifModuleName i) <> text "Streams"
- typesig = text "tower" <> constructor <+> colon <> colon
- <+> text "Tower e"
- <+> parens (constructor <+> text "ChanInput" <> comma
- <+> constructor <+> text "ChanOutput")
- decl = text "tower" <> constructor <+> text "= do"
- body = stack
- [ text n <> text "_c <- channel"
- | (aname, StreamMethod _ _) <- interfaceMethods i
- , let n = userEnumValueName aname
- ]
- ret = text "return" <+> encloseStack lparen rparen comma
- [ mkstream "fst", mkstream "snd"]
- mkstream acc = constructor </> indent 2 (encloseStack lbrace rbrace comma
- [ text n <+> equals <+> text acc <+> text n <> text "_c"
- | (aname, StreamMethod _ _) <- interfaceMethods i
- , let n = userEnumValueName aname
- ])
- interfaceServer :: Interface -> Doc
- interfaceServer i =
- stack [typedef, decl, indent 2 body, indent 2 ret]
- where
- constructor postfix = text (ifModuleName i) <> text postfix
- fname = text "tower" <> constructor "Server"
- typedef = fname <+> align (stack
- [ guardEmptySchema (consumerSchema i)
- (text "::" <+> constructor "Consumer")
- (text ":: -- no consumer schema")
- , guardEmptySchema (consumerSchema i) (text "->") (text " ")
- <+> constructor "Attrs Attr"
- , text "->" <+> constructor "Streams ChanOutput"
- , text "->" <+> text "Tower e"
- <+> guardEmptySchema (producerSchema i)
- (constructor "Producer")
- (text "()")
- ])
- decl = fname <+> guardEmptySchema (consumerSchema i)
- (constructor "Consumer{..}")
- empty
- <+> constructor "Attrs{..}"
- <+> constructor "Streams{..}"
- <+> equals <+> text "do"
- body = stack [ methodBody (text (userEnumValueName n)) m
- | (n,m) <- interfaceMethods i ]
- ret = text "return" <+> guardEmptySchema (producerSchema i)
- (constructor "Producer{..}")
- (text "()")
- methodBody n (StreamMethod _ _) =
- text "let" <+> n <> text "Producer" <+> equals <+> n
- methodBody n (AttrMethod Read t) =
- n <> text "GetRespProducer" <+> text "<- readableAttrServer"
- <+> seqnumGetter t "val" <+> seqnumGetter t "seqnum"
- <+> n <+> n <> text "GetReqConsumer"
- methodBody n (AttrMethod Write t) =
- n <> text "SetRespProducer" <+> text "<- writableAttrServer"
- <+> seqnumGetter t "val" <+> seqnumGetter t "seqnum"
- <+> n <+> n <> text "SetReqConsumer"
- methodBody n (AttrMethod ReadWrite t) =
- parens (n <> text "GetRespProducer" <> comma
- <+> n <> text "SetRespProducer")
- <+> text "<- readwritableAttrServer"
- <+> seqnumGetter t "val" <+> seqnumGetter t "seqnum"
- <+> n <+> n <> text "GetReqConsumer" <+> n <> text "SetReqConsumer"
- seqnumGetter t s = importPrefix (importType (sequenceNumStruct t)) <> dot <> text s
- guardEmptySchema :: Schema -> Doc -> Doc -> Doc
- guardEmptySchema (Schema _ []) _ d = d
- guardEmptySchema (Schema _ _) d _ = d
|