Commit 66e0f309 authored by Sophie Herold's avatar Sophie Herold 🌼

Cleanup and YamSql/HamSql separation

parent 362b3b95
Pipeline #796 failed with stage
in 4 minutes and 20 seconds
......@@ -57,6 +57,7 @@ library
Database.YamSql.Internal.Basic
Database.YamSql.Internal.Commons
Database.YamSql.Internal.SqlId
Database.YamSql.Internal.Utils
Database.YamSql.Parser
other-modules:
......@@ -82,7 +83,7 @@ library
Paths_hamsql
build-depends:
aeson >=1.1 && <1.2,
aeson >=1.2 && <1.3,
base >=4.8 && <5.0,
bytestring >=0.10 && <0.11,
containers >=0.5 && <0.6,
......@@ -91,7 +92,6 @@ library
file-embed >=0.0 && <0.1,
filepath >=1.4 && <1.5,
frontmatter >=0.1 && <0.2,
groom >=0.1 && < 0.2,
network-uri >=2.6 && <2.7,
optparse-applicative >=0.13 && <0.14,
postgresql-simple >=0.4 && <0.6,
......@@ -99,6 +99,7 @@ library
transformers >=0.5 && <0.6,
unordered-containers >=0.2 && <0.3,
yaml >=0.8 && <0.9,
pretty-simple,
edit-distance
ghc-options:
......@@ -142,7 +143,7 @@ test-suite hamsql-tests
tasty,
tasty-hunit,
-- dev
hindent
hindent == 5.2.3
ghc-options:
-Wall
-Wcompat
......
......@@ -4,7 +4,7 @@
-- Some rights reserved. See COPYING, AUTHORS.
module Database.HamSql.Internal.InquireDeployed where
import Data.Text (stripPrefix, stripSuffix, intercalate)
import Data.Text (intercalate, stripPrefix, stripSuffix)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Database.PostgreSQL.Simple.Types (PGArray(..), fromPGArray)
......
......@@ -5,23 +5,20 @@
module Database.HamSql.Internal.Utils
( module Data.Maybe
, module Database.HamSql.Internal.Utils
, Text
, (<>)
, module Database.YamSql.Internal.Utils
) where
import Data.List (group, intercalate, sort)
import Data.Maybe
import Data.Semigroup ((<>))
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Debug.Trace
import System.Exit
import System.IO (stderr)
import System.IO.Unsafe
import Text.Groom
import Database.HamSql.Internal.Option
import Database.YamSql.Internal.Utils
join :: [a] -> [[a]] -> [a]
join = intercalate
......@@ -75,11 +72,6 @@ maybeJoin :: Maybe [a] -> Maybe [a] -> Maybe [a]
maybeJoin Nothing Nothing = Nothing
maybeJoin xs ys = Just (fromMaybe [] xs ++ fromMaybe [] ys)
-- | Takes the right value, if Just there
maybeRight :: Maybe a -> Maybe a -> Maybe a
maybeRight _ (Just r) = Just r
maybeRight l _ = l
fromJustReason :: Text -> Maybe a -> a
fromJustReason _ (Just x) = x
fromJustReason reason Nothing = err $ "fromJust failed: " <> reason
......@@ -94,11 +86,6 @@ selectUniqueReason msgt xs =
") found while trying to extrac one: " <>
msgt
tshow
:: (Show a)
=> a -> Text
tshow = T.replace "\\\"" "“" . pack . groom
showCode :: Text -> Text
showCode = T.replace "\n" "\n " . T.cons '\n'
......@@ -111,9 +98,6 @@ tr
=> a -> a
tr x = trace (show x <> "\n") x
isIn :: Char -> Text -> Bool
isIn c t = T.singleton c `T.isInfixOf` t
(<->) :: Text -> Text -> Text
(<->) a b = a <> " " <> b
......
......@@ -23,9 +23,7 @@ data SetupContext = SetupContext
}
data SetupElement where
SetupElement
:: (ToSqlStmts a)
=> a -> SetupElement
SetupElement :: (ToSqlStmts a) => a -> SetupElement
instance ToSqlStmts SetupElement where
toSqlStmts x (SetupElement y) = toSqlStmts x y
......
......@@ -3,11 +3,11 @@
-- Copyright 2014-2016 by it's authors.
-- Some rights reserved. See COPYING, AUTHORS.
module Database.YamSql.Internal.Basic
( module Database.HamSql.Internal.Utils
( module Database.YamSql.Internal.Utils
, module Database.YamSql.Internal.SqlId
, module Database.YamSql.Parser
) where
import Database.HamSql.Internal.Utils
import Database.YamSql.Internal.SqlId
import Database.YamSql.Internal.Utils
import Database.YamSql.Parser
......@@ -87,14 +87,12 @@ instance ToJSON FunctionTpl where
applyFunctionTpl :: FunctionTpl -> Function -> Function
applyFunctionTpl t f =
f
{ functionPrivExecute =
maybeRight (functiontplPrivExecute t) (functionPrivExecute f)
{ functionPrivExecute = asum [functionPrivExecute f, functiontplPrivExecute t]
, functionSecurityDefiner =
maybeRight (functiontplSecurityDefiner t) (functionSecurityDefiner f)
, functionOwner = maybeRight (functiontplOwner t) (functionOwner f)
, functionParameters =
maybeJoin (functionParameters f) (functiontplParameters t)
, functionVariables = maybeJoin (functionVariables f) (functiontplVariables t)
asum [functionSecurityDefiner f, functiontplSecurityDefiner t]
, functionOwner = asum [functionOwner f, functiontplOwner t]
, functionParameters = functionParameters f <> functiontplParameters t
, functionVariables = functionVariables f <> functiontplVariables t
, functionBody =
Just $
maybeStringL (functiontplBodyPrelude t) <> fromMaybe "" (functionBody f) <>
......
......@@ -87,7 +87,7 @@ instance ToSqlId (SqlContext (Schema, Function)) where
SqlObj
SQL_FUNCTION
( schemaName s <.> functionName x
, maybeMap variableType $ functionParameters x)
, map variableType $ fromMaybe [] $ functionParameters x)
instance ToSqlId (SqlContext (Schema, Sequence)) where
sqlId (SqlContext (s, x)) =
......
......@@ -85,19 +85,19 @@ instance ToSqlCode SQL_COLUMN where
applyTableTpl :: TableTpl -> Table -> Table
applyTableTpl tpl t =
t
{ tableColumns = fromMaybe [] (tabletplColumns tpl) ++ tableColumns t
, tableForeignKeys = maybeJoin (tabletplForeignKeys tpl) (tableForeignKeys t)
, tableInherits = maybeJoin (tabletplInherits tpl) (tableInherits t)
, tableChecks = maybeJoin (tabletplChecks tpl) (tableChecks t)
, tablePrivSelect = maybeJoin (tabletplPrivSelect tpl) (tablePrivSelect t)
, tablePrivInsert = maybeJoin (tabletplPrivInsert tpl) (tablePrivInsert t)
, tablePrivUpdate = maybeJoin (tabletplPrivUpdate tpl) (tablePrivUpdate t)
, tablePrivDelete = maybeJoin (tabletplPrivDelete tpl) (tablePrivDelete t)
{ tableColumns = fromMaybe [] (tabletplColumns tpl) <> tableColumns t
, tableForeignKeys = tabletplForeignKeys tpl <> tableForeignKeys t
, tableInherits = tabletplInherits tpl <> tableInherits t
, tableChecks = tabletplChecks tpl <> tableChecks t
, tablePrivSelect = tabletplPrivSelect tpl <> tablePrivSelect t
, tablePrivInsert = tabletplPrivInsert tpl <> tablePrivInsert t
, tablePrivUpdate = tabletplPrivUpdate tpl <> tablePrivUpdate t
, tablePrivDelete = tabletplPrivDelete tpl <> tablePrivDelete t
}
data IndexName
= IndexNameUnprefixed SqlName
| IndexNamePrefixed { indexnamePrefixed :: SqlName }
| IndexNamePrefixed { indexnamePrefixed :: SqlName}
deriving (Generic, Show, Data)
instance FromJSON IndexName where
......
......@@ -10,11 +10,11 @@
module Database.YamSql.Internal.SqlId where
import Data.Semigroup
import Data.Semigroup (Semigroup)
import qualified Data.Text as T
import Data.Typeable
import Database.HamSql.Internal.Utils
import Database.YamSql.Internal.Utils
import Database.YamSql.Parser
-- | Idable
......@@ -29,9 +29,7 @@ class (Typeable a, ToSqlCode a, Eq a, Show a) =>
-- | SqlId
data SqlId where
SqlId
:: (SqlObjType a, SqlIdContent b)
=> SqlObj a b -> SqlId
SqlId :: (SqlObjType a, SqlIdContent b) => SqlObj a b -> SqlId
sqlIdShowType :: SqlId -> Text
sqlIdShowType (SqlId x) = tshow $ sqlObjType x
......@@ -71,11 +69,7 @@ class (Typeable a, ToSqlCode a, Show a) =>
SqlObjType a
data SqlObj a b where
SqlObj
:: (SqlObjType a, SqlIdContent b)
=> a -- sqlObjType
-> b -- sqlObjId
-> SqlObj a b
SqlObj :: (SqlObjType a, SqlIdContent b) => a -> b -> SqlObj a b
sqlObjType :: SqlObj a b -> a
sqlObjType (SqlObj x _) = x
......
......@@ -17,22 +17,23 @@ module Database.YamSql.Parser
import Control.Exception
import Data.Aeson.Types
(GFromJSON, GToJSON, Options(..), defaultOptions, genericParseJSON,
genericToJSON, Zero, SumEncoding(UntaggedValue))
(GFromJSON, GToJSON, Options(..), SumEncoding(UntaggedValue), Zero,
defaultOptions, genericParseJSON, genericToJSON)
import Data.Char
import Data.Data
import Data.HashMap.Strict (keys)
import Data.List ((\\), minimumBy)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Yaml
import GHC.Generics
import System.IO
import Text.EditDistance
(defaultEditCosts, levenshteinDistance, substitutionCosts,
Costs(ConstantCost))
(Costs(ConstantCost), defaultEditCosts, levenshteinDistance,
substitutionCosts)
import Database.HamSql.Internal.Utils
import Database.YamSql.Internal.Utils
-- removes first part of camel case. e.g.:
-- columnDescriptionField |-> descriptionField
......
......@@ -61,6 +61,7 @@ selfTestStmt :: TestTree
selfTestStmt =
testCaseSteps "stmt" $ \step -> do
(schemasDb, setupLocal) <- deploy step "test/setups/self-test.yml"
--B.putStrLn $ encodePretty (setConfDropNull True defConfig) (setupLocal)
step "check statement diff"
assertNoDiff
(pgsqlGetFullStatements (newSetup schemasDb))
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment