diff --git a/app/Main.hs b/app/Main.hs index c2122c2..079ee28 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Main where import qualified Data.ByteString.Lazy as BS diff --git a/app/Ringo/ArgParser.hs b/app/Ringo/ArgParser.hs index fe7726a..7bdfada 100644 --- a/app/Ringo/ArgParser.hs +++ b/app/Ringo/ArgParser.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ringo.ArgParser (ProgArgs(..), parseArgs) where import qualified Data.Text as Text diff --git a/app/Ringo/InputParser.hs b/app/Ringo/InputParser.hs index 0ae0912..6182bfe 100644 --- a/app/Ringo/InputParser.hs +++ b/app/Ringo/InputParser.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} module Ringo.InputParser (parseInput) where import qualified Data.Text as Text diff --git a/ringo.cabal b/ringo.cabal index f75207d..109c8cf 100644 --- a/ringo.cabal +++ b/ringo.cabal @@ -34,8 +34,6 @@ library raw-strings-qq >=1.0 && <1.2, hssqlppp ==0.5.23 ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans -O2 - default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, BangPatterns, - TupleSections, CPP, NamedFieldPuns default-language: Haskell2010 executable ringo @@ -55,16 +53,16 @@ executable ringo aeson >=0.8 && <0.11, ringo ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans -O2 - default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, BangPatterns, - TupleSections, CPP, NamedFieldPuns default-language: Haskell2010 test-suite ringo-test type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs + hs-source-dirs: test, src + main-is: doctests.hs build-depends: base , ringo + , pretty-show >=1.6 && <1.7 + , doctest >=0.9 && <0.11 default-language: Haskell2010 source-repository head diff --git a/src/Ringo.hs b/src/Ringo.hs index 9306bf7..2d8a3c2 100644 --- a/src/Ringo.hs +++ b/src/Ringo.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ringo - ( module Ringo.Types + ( -- | The examples in this module assume the following code has been run. + -- The :{ and :} will only work in GHCi. + + -- $setup + module Ringo.Types , extractFactTable , extractDimensionTables , extractDependencies @@ -19,18 +25,200 @@ import qualified Ringo.Extractor as E import qualified Ringo.Generator as G import qualified Ringo.Validator as V +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Ringo +-- >>> import qualified Data.Map as Map +-- >>> import qualified Data.Text as Text +-- >>> import Text.Show.Pretty +-- >>> :{ +--let sessionEventsTable = +-- Table { tableName = "session_events" +-- , tableColumns = +-- [ Column "id" "uuid" NotNull +-- , Column "created_at" "timestamp without time zone" Null +-- , Column "member_id" "integer" Null +-- , Column "publisher_id" "integer" NotNull +-- , Column "user_agent" "character varying(1024)" Null +-- , Column "browser_name" "character varying(50)" Null +-- , Column "os" "character varying(50)" Null +-- , Column "geo_country_name" "character varying(50)" Null +-- , Column "geo_city_name" "character varying(50)" Null +-- , Column "geo_continent_name" "character varying(15)" Null +-- , Column "geo_most_specific_subdivision_name" "character varying(100)" Null +-- , Column "geo_longitude" "numeric(9,6)" Null +-- , Column "geo_latitude" "numeric(9,6)" Null +-- , Column "geo_time_zone" "character varying(20)" Null +-- , Column "geo_postal_code" "character varying(20)" Null +-- , Column "user_agent_name" "character varying(100)" Null +-- , Column "user_agent_type" "character varying(15)" Null +-- , Column "user_agent_version" "character varying(100)" Null +-- , Column "user_agent_device" "character varying(15)" Null +-- ] +-- , tableConstraints = +-- [ PrimaryKey "id" ] +-- } +-- sessionFact = +-- Fact { factName = "session" +-- , factTableName = "session_events" +-- , factParentNames = [] +-- , factColumns = +-- [ DimTime "created_at" +-- , NoDimId "publisher_id" +-- , DimVal "user_agent" "browser_name" +-- , DimVal "user_agent" "os" +-- , DimVal "user_agent" "user_agent_name" +-- , DimVal "user_agent" "user_agent_type" +-- , DimVal "user_agent" "user_agent_device" +-- , DimVal "geo" "geo_country_name" +-- , DimVal "geo" "geo_city_name" +-- , DimVal "geo" "geo_continent_name" +-- , DimVal "geo" "geo_most_specific_subdivision_name" +-- , DimVal "geo" "geo_time_zone" +-- , FactCount Nothing "session_count" +-- ] +-- } +-- tables = [sessionEventsTable] +-- facts = [sessionFact] +-- typeDefaults = Map.fromList [ ("integer", "-1") +-- , ("timestamp", "'00-00-00 00:00:00'") +-- , ("character", "'__UNKNOWN_VAL__'") +-- , ("uuid", "'00000000-0000-0000-0000-000000000000'::uuid") +-- , ("boolean", "false") +-- , ("json", "'{}'::json") +-- , ("numeric", "-1") +-- , ("text", "'__UNKNOWN_VAL__'") +-- ] +-- settings = defSettings { settingTableNameSuffixTemplate = "" } +-- env = Env tables facts settings typeDefaults +-- :} + +-- | +-- +-- >>> print $ extractFactTable env sessionFact +-- Table fact_session_by_minute +-- Column created_at_minute_id bigint NOT NULL +-- Column publisher_id integer NOT NULL +-- Column session_count integer NOT NULL +-- Column geo_id integer NOT NULL +-- Column user_agent_id integer NOT NULL +-- UniqueKey (created_at_minute_id, publisher_id, geo_id, user_agent_id) +-- extractFactTable :: Env -> Fact -> Table extractFactTable env = flip runReader env . E.extractFactTable +-- | +-- +-- >>> mapM_ print $ extractDimensionTables env sessionFact +-- Table dim_geo +-- Column id serial NOT NULL +-- Column country_name character varying(50) NOT NULL +-- Column city_name character varying(50) NOT NULL +-- Column continent_name character varying(15) NOT NULL +-- Column most_specific_subdivision_name character varying(100) NOT NULL +-- Column time_zone character varying(20) NOT NULL +-- PrimaryKey id +-- UniqueKey (country_name, city_name, continent_name, most_specific_subdivision_name, time_zone) +-- +-- Table dim_user_agent +-- Column id serial NOT NULL +-- Column browser_name character varying(50) NOT NULL +-- Column os character varying(50) NOT NULL +-- Column name character varying(100) NOT NULL +-- Column type character varying(15) NOT NULL +-- Column device character varying(15) NOT NULL +-- PrimaryKey id +-- UniqueKey (browser_name, os, name, type, device) +-- extractDimensionTables :: Env -> Fact -> [Table] extractDimensionTables env = flip runReader env . E.extractDimensionTables +-- | +-- +-- >>> putStrLn . ppShow $ extractDependencies env sessionFact +-- fromList +-- [ ( "dim_geo" , [ "session_events" ] ) +-- , ( "dim_user_agent" , [ "session_events" ] ) +-- , ( "fact_session_by_minute" +-- , [ "session_events" , "dim_user_agent" , "dim_geo" ] +-- ) +-- ] extractDependencies :: Env -> Fact -> Dependencies extractDependencies env = flip runReader env . E.extractDependencies +-- | +-- +-- >>> let storySessionDimTables = extractDimensionTables env sessionFact +-- >>> let sqls = map (tableDefnSQL env) storySessionDimTables +-- >>> mapM_ (\sqls -> mapM_ (putStr . Text.unpack) sqls >> putStrLn "--------" ) sqls +-- create table dim_geo ( +-- id serial not null, +-- country_name character varying(50) not null, +-- city_name character varying(50) not null, +-- continent_name character varying(15) not null, +-- most_specific_subdivision_name character varying(100) not null, +-- time_zone character varying(20) not null +-- ) +-- ; +-- +-- alter table dim_geo add primary key (id); +-- +-- alter table dim_geo add unique (country_name, +-- city_name, +-- continent_name, +-- most_specific_subdivision_name, +-- time_zone); +-- +-- -------- +-- create table dim_user_agent ( +-- id serial not null, +-- browser_name character varying(50) not null, +-- os character varying(50) not null, +-- name character varying(100) not null, +-- type character varying(15) not null, +-- device character varying(15) not null +-- ) +-- ; +-- +-- alter table dim_user_agent add primary key (id); +-- +-- alter table dim_user_agent add unique (browser_name, +-- os, +-- name, +-- type, +-- device); +-- +-- -------- tableDefnSQL :: Env -> Table -> [Text] tableDefnSQL env = flip runReader env . G.tableDefnSQL +-- | +-- +-- >>> let storySessionFactTable = extractFactTable env sessionFact +-- >>> let sqls = factTableDefnSQL env sessionFact storySessionFactTable +-- >>> mapM_ (putStr . Text.unpack) sqls +-- create table fact_session_by_minute ( +-- created_at_minute_id bigint not null, +-- publisher_id integer not null, +-- session_count integer not null, +-- geo_id integer not null, +-- user_agent_id integer not null +-- ) +-- ; +-- +-- alter table fact_session_by_minute add unique (created_at_minute_id, +-- publisher_id, +-- geo_id, +-- user_agent_id); +-- +-- create index on fact_session_by_minute (created_at_minute_id) +-- ; +-- create index on fact_session_by_minute (publisher_id) +-- ; +-- create index on fact_session_by_minute (geo_id) +-- ; +-- create index on fact_session_by_minute (user_agent_id) +-- ; factTableDefnSQL :: Env -> Fact -> Table -> [Text] factTableDefnSQL env fact = flip runReader env . G.factTableDefnSQL fact diff --git a/src/Ringo/Extractor.hs b/src/Ringo/Extractor.hs index 398a676..2abcfd4 100644 --- a/src/Ringo/Extractor.hs +++ b/src/Ringo/Extractor.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ringo.Extractor ( extractDimensionTables , extractAllDimensionTables diff --git a/src/Ringo/Extractor/Internal.hs b/src/Ringo/Extractor/Internal.hs index c6af1f4..1b5c59c 100644 --- a/src/Ringo/Extractor/Internal.hs +++ b/src/Ringo/Extractor/Internal.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} module Ringo.Extractor.Internal where import qualified Data.Map as Map diff --git a/src/Ringo/Generator/Create.hs b/src/Ringo/Generator/Create.hs index adf791e..5570f42 100644 --- a/src/Ringo/Generator/Create.hs +++ b/src/Ringo/Generator/Create.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} module Ringo.Generator.Create (tableDefnSQL, factTableDefnSQL) where #if MIN_VERSION_base(4,8,0) diff --git a/src/Ringo/Generator/Internal.hs b/src/Ringo/Generator/Internal.hs index fd8e77c..3b776f8 100644 --- a/src/Ringo/Generator/Internal.hs +++ b/src/Ringo/Generator/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ringo.Generator.Internal where import qualified Data.Map as Map diff --git a/src/Ringo/Generator/Populate/Dimension.hs b/src/Ringo/Generator/Populate/Dimension.hs index a5cc5f7..eead3b1 100644 --- a/src/Ringo/Generator/Populate/Dimension.hs +++ b/src/Ringo/Generator/Populate/Dimension.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} module Ringo.Generator.Populate.Dimension (dimensionTablePopulateSQL) where import qualified Data.Text as Text diff --git a/src/Ringo/Generator/Populate/Fact.hs b/src/Ringo/Generator/Populate/Fact.hs index fe3901b..75d4c7a 100644 --- a/src/Ringo/Generator/Populate/Fact.hs +++ b/src/Ringo/Generator/Populate/Fact.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} module Ringo.Generator.Populate.Fact (factTablePopulateSQL) where diff --git a/src/Ringo/Generator/Sql.hs b/src/Ringo/Generator/Sql.hs index 1c0692b..2a8ed41 100644 --- a/src/Ringo/Generator/Sql.hs +++ b/src/Ringo/Generator/Sql.hs @@ -3,7 +3,6 @@ module Ringo.Generator.Sql where import qualified Data.Text as Text import qualified Data.Text.Lazy as TL - import Database.HsSqlPpp.Annotation import Database.HsSqlPpp.Dialect (postgresDialect) import Database.HsSqlPpp.Pretty diff --git a/src/Ringo/Types.hs b/src/Ringo/Types.hs index e2e09b6..77244d4 100644 --- a/src/Ringo/Types.hs +++ b/src/Ringo/Types.hs @@ -1,32 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} module Ringo.Types where import qualified Data.Text as Text -import Data.Map (Map) -import Data.Text (Text) +import Data.Map (Map) +import Data.Monoid ((<>)) +import Data.Text (Text) + +showColNames :: [Text] -> String +showColNames cols = Text.unpack $ "(" <> Text.intercalate ", " cols <> ")" type ColumnName = Text type ColumnType = Text type TableName = Text -data Nullable = Null | NotNull deriving (Eq, Enum, Show) +data Nullable = Null | NotNull deriving (Eq, Enum) + +instance Show Nullable where + show Null = "NULL" + show NotNull = "NOT NULL" data Column = Column { columnName :: !ColumnName , columnType :: !ColumnType , columnNullable :: !Nullable - } deriving (Eq, Show) + } deriving (Eq) + +instance Show Column where + show Column {..} = "Column " + ++ Text.unpack columnName ++ " " + ++ Text.unpack columnType ++ " " + ++ show columnNullable data TableConstraint = PrimaryKey !ColumnName | UniqueKey ![ColumnName] | ForeignKey !TableName ![(ColumnName, ColumnName)] - deriving (Eq, Show) + deriving (Eq) + +instance Show TableConstraint where + show (PrimaryKey col) = "PrimaryKey " ++ Text.unpack col + show (UniqueKey cols) = "UniqueKey " ++ showColNames cols + show (ForeignKey tName colMap) = "ForeignKey " ++ showColNames (map fst colMap) ++ " " + ++ Text.unpack tName ++ " " ++ showColNames (map snd colMap) data Table = Table { tableName :: !TableName , tableColumns :: ![Column] , tableConstraints :: ![TableConstraint] - } deriving (Eq, Show) + } deriving (Eq) + +instance Show Table where + show Table {..} = + unlines $ ("Table " ++ Text.unpack tableName) : (map show tableColumns) ++ (map show tableConstraints) data TimeUnit = Second | Minute | Hour | Day | Week deriving (Eq, Enum, Show, Read) diff --git a/src/Ringo/Utils.hs b/src/Ringo/Utils.hs index 69400d6..cc94de9 100644 --- a/src/Ringo/Utils.hs +++ b/src/Ringo/Utils.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} module Ringo.Utils where import qualified Control.Arrow as Arrow diff --git a/src/Ringo/Validator.hs b/src/Ringo/Validator.hs index d00bda9..e3c18e5 100644 --- a/src/Ringo/Validator.hs +++ b/src/Ringo/Validator.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} module Ringo.Validator ( validateTable , validateFact diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 index 0000000..1d68649 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,2 @@ +import Test.DocTest +main = doctest ["-isrc", "Ringo"]