starting work on generating database plugin, not done, but compiles

ServerTemplate/src/Plugins/Database/Query.hs

@@ -1,8 +1,11 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
 module Plugins.Database.Query where
 import Data.Data (Data, Typeable)
 import Data.IxSet ( Indexable(..), IxSet(..), Proxy(..), getOne
                   , ixFun, ixSet, getEQ, getLT, getGT, getLTE, getGTE
                   , union, intersection )
+import Data.Word (Word64)
 
 
 {-data Query a key where 
@@ -33,47 +36,72 @@ type Query r = IxSet r -> IxSet r
 (@==) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> a -> Query r
 (@==) keyFn a =
     getEQ (keyFn a)
+infix 6 @==
 
 (@<) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> a -> Query r
 (@<) keyFn a =
     getLT (keyFn a)
+infix 6 @<
 
 (@>) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> a -> Query r
 (@>) keyFn a =
     getGT (keyFn a)
+infix 6 @>
 
 (@<=) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> a -> Query r
 (@<=) keyFn a =
     getLTE (keyFn a)
+infix 6 @<=
 
 (@>=) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> a -> Query r
 (@>=) keyFn a =
     getGTE (keyFn a)
+infix 6 @>=
 
 (@><) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> (a,a) -> Query r
 (@><) keyFn (a,b) =
     getGT (keyFn a) . getLT (keyFn b)
+infix 6 @><
 
 (@><=) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> (a,a) -> Query r
 (@><=) keyFn (a,b) =
     getGT (keyFn a) . getLTE (keyFn b)
+infix 6 @><=
 
 (@=><) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> (a,a) -> Query r
 (@=><) keyFn (a,b) =
     getGTE (keyFn a) . getLT (keyFn b)
+infix 6 @=><
 
 (@=><=) :: (Indexable r, Typeable r, Ord r, Typeable key) => (a -> key) -> (a,a) -> Query r
 (@=><=) keyFn (a,b) =
     getGTE (keyFn a) . getLTE (keyFn b)
+infix 6 @=><=
 
 (&&&) :: (Indexable r, Typeable r, Ord r) => Query r -> Query r -> Query r
 (&&&) q0 q1 =
     \ix -> intersection (q0 ix) (q1 ix)
+infixl 5 &&&
 
 (|||) :: (Indexable r, Typeable r, Ord r) => Query r -> Query r -> Query r
 (|||) q0 q1 =
     \ix -> union (q0 ix) (q1 ix)
+infixl 5 |||
+
+type Index = Word64
+type Row r = (Index, r)
 
+data QueryOptions =
+      forall k. Typeable k => Asc k
+    | forall k. Typeable k => Dsc k
+    | LimitTo Word64
+    | OffsetBy Word64
+
+--commands
+{-
+doQuery :: Query (Row r) -> ([Row r] -> msg) -> Cmd msg
+doQuery = StateCmd $ \()
+-}
 {-
 (@==) :: Typeable key => (a -> key) -> a -> Query r
 (@==) keyFn a =

elm-haskell-state-diagram.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 4da1eee4b626b7d9120ea74d98b587dd0cc02e543c61b3c890aeeb92abac7423
+-- hash: fef44100b0d867bba52865609b0cd4286ec01e658022ff18b3892b76eb1055a7
 
 name:           elm-haskell-state-diagram
 version:        0.1.0.0
@@ -36,6 +36,7 @@ library
       Generate.Helpers
       Generate.OneOf
       Generate.Plugins
+      Generate.Plugins.Database
       Generate.Server
       Generate.Standalone
       Generate.Types

package.yaml

@@ -28,6 +28,7 @@ dependencies:
 - directory
 - process
 
+
 library:
   source-dirs: src
 

src/ClientServerSpec.hs

@@ -3,6 +3,7 @@ module ClientServerSpec where
 import Types
 import TypeHelpers
 import Data.Map as M
+import Generate.Plugins.Database
 
 --where to output generated files
 outputDirectory = "../elm-number-race/"
@@ -81,7 +82,9 @@ clientServerApp = (
              ,  []        --extra server types
              ,  csDiagram --client state diagram
              ,  ssDiagram --server state diagram
-             ,  [Plugin "Incrementer"]
+             ,  [ Plugin "Incrementer"
+                --, PluginGen "Database" (generateDatabase [Table "People" [(ElmString,"name","")] []])
+                ]
              )
 
 clientConnect = ("ClientConnect",[])

src/Generate/Helpers.hs

@@ -7,7 +7,6 @@ import Types
 import qualified Data.Text as T
 import                  System.FilePath.Posix   ((</>),(<.>))
 import Generate.Types
-import Data.Char (toUpper)
 import Utils
 import                  Data.Time               (getCurrentTime)
 
@@ -75,10 +74,4 @@ generateHelper h (sn,edts) getOnly =
                 [
                     T.unlines $ map generateSetter edts
                 ,   T.unlines $ map generateUpdater edts
-                ] else [])
-
-capitalize :: T.Text -> T.Text
-capitalize txt =
-    case T.unpack txt of
-        h:rest -> T.pack $ toUpper h : rest
-        _ -> txt
+                ] else [])

src/Generate/Plugins.hs

@@ -4,21 +4,28 @@ module Generate.Plugins where
 
 import qualified Data.Text as T
 import Types
+import                  System.FilePath.Posix   ((</>),(<.>))
+import Utils
 
-generatePlugins :: [Plugin] -> T.Text
-generatePlugins ps = 
+
+generatePlugins :: FilePath -> [Plugin] -> IO ()
+generatePlugins fp ps = 
     let
         onePlugin n (Plugin name) = T.concat["    (_,rp",T.pack $ show n,") <- forkIO $ (initPlugin :: IO Plugins.",T.pack name,".",T.pack name,")"]
+        onePlugin n (PluginGen name _) = T.concat["    (_,rp",T.pack $ show n,") <- forkIO $ (initPlugin :: IO Plugins.",T.pack name,".",T.pack name,")"]
         oneResult n               = T.concat["    p",T.pack $ show n," <- result =<< rp", T.pack $ show n]
-        return n                  = T.concat["    return $ ",T.concat $ map (\n -> T.concat ["TM.insert p",T.pack $ show n," $ "]) [0..length ps - 1], "TM.empty"]
-    in
-        T.unlines $
-            [
+        ret n                     = T.concat["    return $ ",T.concat $ map (\n -> T.concat ["TM.insert p",T.pack $ show n," $ "]) [0..length ps - 1], "TM.empty"]
+    in do
+        writeIfNew 0 (fp </> "server" </> "src" </> "Static" </> "Plugins" <.> "hs") $ T.unlines
+            ([
                 "module Static.Plugins where"
             ,   "import Static.ServerTypes"
             ,   "import qualified Data.TMap as TM"
             ,   "import Control.Concurrent.Thread (forkIO, result)\n"
-            ,   T.concat $ map (\(Plugin p) -> T.concat["import qualified Plugins.",T.pack p,"\n"]) ps,""
+            ,   T.concat $ map (\p -> case p of 
+                                    Plugin n -> T.concat["import qualified Plugins.",T.pack n,"\n"]
+                                    PluginGen n _ -> T.concat["import qualified Plugins.",T.pack n,"\n"]
+                                ) ps,""
             ,   "initStateCmds :: IO PluginState"
             ,   "initStateCmds = do"
             ] 
@@ -27,6 +34,13 @@ generatePlugins ps =
             ++
             (map oneResult [0..length ps - 1])
             ++
-            [
-                return $ length ps
-            ]
+            [ ret $ length ps ])
+        mapM_ (\p -> 
+                    case p of 
+                        Plugin _ -> return ()
+                        PluginGen name gen -> do
+                            g <- gen
+                            mapM_ (\(n,t) -> 
+                                    writeIfNew 0 (if n == "" then fp </> "server" </> "src" </> "Plugins" </> name <.> "hs"
+                                                  else fp </> "server" </> "src" </> "Plugins" </> name </> n <.> "hs") t) g
+            ) ps -- generate other files for plugins

src/Generate/Plugins/Database.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Generate.Plugins.Database where
+
+import Types
+import TypeHelpers
+import Generate.Types
+import qualified Data.Text as T
+import Utils
+
+type Key = ElmDocType
+type Data = ElmDocType
+
+data Table = 
+    Table String {-the name of the table-} [Key] {-the keys in the row-} [Data] {-the data in the row-}
+
+generateDatabase :: [Table] -> IO [(FilePath, T.Text)]
+generateDatabase ts =
+    let
+        generateOneTable (Table name keys dat) =
+            let
+                rowT = ec name $ [constructor name (keys++dat)]
+                safecopy n = T.concat ["$(deriveSafeCopy 0 'base ", "''",T.pack $ n,")"]
+            in T.unlines 
+                [
+                    "{-# LANGUAGE TemplateHaskell #-}"
+                ,   T.concat["module Plugins.Database.Table.",T.pack name," where"]
+                ,   "import Data.Data            (Data, Typeable)"
+                ,   "import Data.IxSet           (Indexable(..), IxSet(..), (@=), Proxy(..), getOne, ixFun, ixSet)"
+                ,   "import Data.SafeCopy        (SafeCopy, base, deriveSafeCopy)"
+                ,   "import Static.Types"
+                ,   "import Plugins.Database.Query",""
+                ,   generateType True True [DOrd,DEq,DShow,DData,DTypeable] rowT,""
+                ,   generateNewtype True [DOrd,DEq,DShow,DData,DTypeable] (name++"Record") (ElmPair (ElmType "Index", "index", "") (ElmType name, name, ""))
+                ,   safecopy (name++"Record"),""
+                ,   T.unlines $ map (\(et,n,_) -> generateNewtype True [DOrd,DEq,DShow,DData,DTypeable] (capStr n) et) keys
+                ,   T.unlines $ map (\(_,n,_) -> safecopy n) keys
+                ]
+        main = T.unlines 
+                [
+                    "module Plugins.Database where"
+                ,   T.unlines $ map (\(Table name _ _) -> T.concat ["import Plugins.Database.Table.",T.pack name]) ts
+                ,   ""
+                ]
+    in
+        return $ [("", main)] ++
+                 map (\(table@(Table name _ _)) -> ("Table/"++name,generateOneTable table)) ts
+

src/Generate/Server.hs

@@ -851,6 +851,6 @@ generateServer gsvg onlyStatic fp (startCs
         createDirectoryIfMissing True $ fp </> "server" </> "src" </> "Static" </> "Helpers"
         createDirectoryIfMissing True $ fp </> "client" </> "src" </> "Static" </> "Helpers"
         generateHelpers fp (M.elems cStates) sStateslst
-        writeIfNew 0 (fp </> "server" </> "src" </> "Static" </> "Plugins" <.> "hs") $ generatePlugins plugins
+        generatePlugins fp plugins
 
         print serverTransitions

src/Generate/Types.hs

@@ -9,7 +9,15 @@ import qualified Data.Set       as S
 import Data.Maybe (mapMaybe)
 
 data Deriving = 
-    DOrd | DShow | DEq
+    DOrd | DShow | DEq | DData | DTypeable
+
+
+deriv2Txt DOrd = "Ord"
+deriv2Txt DShow = "Show"
+deriv2Txt DEq = "Eq"
+deriv2Txt DData = "Data"
+deriv2Txt DTypeable = "Typeable"
+derivTxt deriv = T.concat ["(",T.intercalate "," $ map deriv2Txt deriv,")"]
 
 generateType :: Bool -> Bool -> [Deriving] -> ElmCustom -> T.Text
 generateType haskell commentsEnabled deriv (ElmCustom typeName constrs) =
@@ -24,18 +32,32 @@ generateType haskell commentsEnabled deriv (ElmCustom typeName constrs) =
                                 _ -> Nothing                
                             ) constr
                         ) constrs
-        deriv2Txt DOrd = "Ord"
-        deriv2Txt DShow = "Show"
-        deriv2Txt DEq = "Eq"
-        derivTxt = T.concat ["(",T.intercalate "," $ map deriv2Txt deriv,")"]
     in
         if length constrs > 0 then
         T.concat [ typ, " ", T.pack typeName, " ", T.intercalate " " typeParams ," =\n      "
                  , T.intercalate "\n    | " constrs2Txt
-                 , if length deriv > 0 && haskell then T.concat ["\n    deriving",derivTxt] else ""
+                 , if length deriv > 0 && haskell then T.concat ["\n    deriving",derivTxt deriv] else ""
                  ]
         else ""
 
+generateTypeAlias :: Bool -> Bool -> [Deriving] -> String -> ElmType -> T.Text
+generateTypeAlias haskell commentsEnabled deriv typeName et =
+    let
+        typ = if haskell then "type" else "type alias"
+    in
+        T.concat [ typ, " ", T.pack typeName, " = ",T.pack typeName, " ", et2Txt haskell commentsEnabled et
+                 , if length deriv > 0 && haskell then T.concat ["   deriving",derivTxt deriv] else ""
+                 ]
+
+generateNewtype :: Bool -> [Deriving] -> String -> ElmType -> T.Text
+generateNewtype commentsEnabled deriv typeName et =
+    let
+        typ = "newtype"
+    in
+        T.concat [ typ, " ", T.pack typeName, " = ", et2Txt True commentsEnabled et
+                 , if length deriv > 0 then T.concat ["   deriving",derivTxt deriv] else ""
+                 ]
+
 generateConstructor :: Bool -> Bool -> Constructor -> T.Text
 generateConstructor haskell commentsEnabled (constrName,elmDocTypes) =
     T.intercalate " " $ T.pack constrName : map (edt2Txt haskell commentsEnabled) elmDocTypes

src/Types.hs

@@ -4,6 +4,7 @@ module Types where
 
 import Data.Map as M
 import Data.String
+import qualified Data.Text as T
 
 -- paper 1 will stick to messages arriving in order (websockets)
 -- paper 2 will allow messages out of order (webrtc)
@@ -76,4 +77,5 @@ type ClientServerApp =
     )
 
 data Plugin = 
-    Plugin String
+      Plugin String {-name-}
+    | PluginGen String {-name-} (IO [(FilePath,T.Text)]) {-function to generate the plugin-}

src/Utils.hs

@@ -10,6 +10,7 @@ import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
 import                  System.Directory
 import                  Control.Monad (unless)
+import Data.Char (toUpper)
 
 
 
@@ -60,4 +61,16 @@ disclaimer date = T.unlines ["{-"
                         , "    IMPORTANT: USE THIS FILE FOR REFERENCE ONLY. YOU SHOULD NOT MODIFY THIS FILE. INSTEAD, MODIFY THE STATE DIAGRAM AND REGENERATE THIS FILE."
                         , "    MODIFYING ANY FILES INSIDE THE Static DIRECTORY COULD LEAD TO UNEXPECTED ERRORS IN YOUR APP."
                         ,"-}"
-                        ]
+                        ]
+
+capitalize :: T.Text -> T.Text
+capitalize txt =
+    case T.unpack txt of
+        h:rest -> T.pack $ toUpper h : rest
+        _ -> txt
+
+capStr :: String -> String
+capStr str =
+    case str of
+        h:rest -> toUpper h : rest
+        _ -> str