Commit cffa2031 authored by Sophie Herold's avatar Sophie Herold 🌼

Fixes GHC8 errors and formatting

parent 44842383
......@@ -83,7 +83,7 @@ findSchemaPath schema search = findDir search
else findDir ds
catchErrors
:: (FromJSON a, ToJSON a)
:: ToJSON a
=> FilePath -> a -> IO a
catchErrors filePath x = do
y <- try (forceToJson x)
......
......@@ -11,7 +11,7 @@ module Database.HamSql.Internal.Utils
import Data.List (group, intercalate, sort)
import Data.Maybe
import Data.Monoid ((<>))
import Data.Semigroup ((<>))
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
......
......@@ -13,25 +13,26 @@ module Database.HamSql.Setup where
import Data.Typeable
import Data.Yaml
import Database.HamSql.Internal.Stmt
import Database.HamSql.Internal.Utils
import Database.YamSql
import Database.YamSql.Parser
import Database.HamSql.Internal.Stmt
data SetupContext = SetupContext
{ setupContextSetup :: Setup
}
data SetupElement where
SetupElement :: (ToSqlStmts a)
=> { setupElement :: a }
-> SetupElement
SetupElement
:: (ToSqlStmts a)
=> a -> SetupElement
instance ToSqlStmts SetupElement where
toSqlStmts x SetupElement{setupElement=y} = toSqlStmts x y
toSqlStmts x (SetupElement y) = toSqlStmts x y
class (Typeable a) => ToSqlStmts a where
toSqlStmts :: SetupContext -> a -> [Maybe SqlStmt]
class Typeable a =>
ToSqlStmts a where
toSqlStmts :: SetupContext -> a -> [Maybe SqlStmt]
-- | Setup
data Setup = Setup
......@@ -58,7 +59,7 @@ data WithSchema a =
a
deriving (Show)
class WithName a where
class WithName a where
name :: a -> Text
instance WithName (WithSchema TableTpl) where
......@@ -70,18 +71,21 @@ instance WithName (WithSchema FunctionTpl) where
withoutSchema :: WithSchema a -> a
withoutSchema (WithSchema _ t) = t
selectTemplates :: (ToSqlCode a, WithName (WithSchema t)) =>
Maybe [a] -> [WithSchema t] -> [t]
selectTemplates
:: (ToSqlCode a, WithName (WithSchema t))
=> Maybe [a] -> [WithSchema t] -> [t]
selectTemplates ns ts
-- TODO: error handling here should be done using exceptions
=
[ withoutSchema $
selectUniqueReason ("table or function tpl " <> n) $
filter (\t -> n == name t) ts
| n <- maybeMap toSqlCode ns ]
selectTemplate :: (ToSqlCode a1, WithName (WithSchema a)) =>
a1 -> [WithSchema a] -> a
selectUniqueReason ("table or function tpl " <> n) $
filter (\t -> n == name t) ts
| n <- maybeMap toSqlCode ns
]
selectTemplate
:: (ToSqlCode a1, WithName (WithSchema a))
=> a1 -> [WithSchema a] -> a
selectTemplate x ts =
head' $ map withoutSchema $ filter (\y -> name y == toSqlCode x) ts
where
......@@ -95,30 +99,25 @@ setupAllFunctionTemplates :: Setup -> [WithSchema FunctionTpl]
setupAllFunctionTemplates s =
concat
[ maybeMap (WithSchema m) (schemaFunctionTemplates m)
| m <- setupAllSchemas s ]
| m <- setupAllSchemas s
]
setupAllTableTemplates :: Setup -> [WithSchema TableTpl]
setupAllTableTemplates s =
concat
[ maybeMap (WithSchema m) (schemaTableTemplates m)
| m <- setupAllSchemas s ]
[maybeMap (WithSchema m) (schemaTableTemplates m) | m <- setupAllSchemas s]
applyTpl :: Setup -> Setup
applyTpl s =
s
-- TODO: possible overwrite here!
{ setupSchemaData = Just $ maybeMap applySchema (setupSchemaData s)
}
{setupSchemaData = Just $ maybeMap applySchema (setupSchemaData s)}
where
applySchema m =
m
{ schemaTables =
Just $
maybeMap applyTableTemplates (schemaTables m)
{ schemaTables = Just $ maybeMap applyTableTemplates (schemaTables m)
, schemaFunctions =
Just $ maybeMap applyFunctionTemplates (schemaFunctions m)
Just $ maybeMap applyFunctionTemplates (schemaFunctions m)
}
applyTableTemplates :: Table -> Table
applyTableTemplates t = foldr applyTableTpl t (tableTpls t)
......@@ -129,4 +128,3 @@ applyTpl s =
functionTpls :: Function -> [FunctionTpl]
functionTpls f =
selectTemplates (functionTemplates f) (setupAllFunctionTemplates s)
......@@ -5,30 +5,33 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.YamSql.Internal.SqlId where
import Data.Typeable
import Data.Semigroup
import qualified Data.Text as T
import Data.Typeable
import Database.HamSql.Internal.Utils
import Database.YamSql.Parser
-- | Idable
class Show a =>
ToSqlId a where
ToSqlId a where
sqlId :: a -> SqlId
sqlIdCode :: a -> Text
sqlIdCode = toSqlCode . sqlId
class (Typeable a, ToSqlCode a, Eq a, Show a) => SqlIdContent a
class (Typeable a, ToSqlCode a, Eq a, Show a) =>
SqlIdContent 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
......@@ -53,20 +56,32 @@ instance ToSqlId SqlId where
instance ToSqlCode SqlId where
toSqlCode (SqlId x) = toSqlCode $ sqlObjId x
data SqlContext a = SqlContext a
data SqlContext a =
SqlContext a
-- FIXME
instance Show (SqlContext a) where show= const ""
instance Show (SqlContext a) where
show = const ""
instance (SqlObjType a, SqlIdContent b) => ToSqlId (SqlObj a b) where
instance (SqlObjType a, SqlIdContent b) =>
ToSqlId (SqlObj a b) where
sqlId = SqlId
class (Typeable a, ToSqlCode a, Show a) => SqlObjType a
class (Typeable a, ToSqlCode a, Show a) =>
SqlObjType a
data SqlObj a b where
SqlObj :: (SqlObjType a, SqlIdContent b)
=> { sqlObjType :: a , sqlObjId :: b }
-> SqlObj a b
SqlObj
:: (SqlObjType a, SqlIdContent b)
=> a -- ^ sqlObjType
-> b -- ^ sqlObjId
-> SqlObj a b
sqlObjType :: SqlObj a b -> a
sqlObjType (SqlObj x _) = x
sqlObjId :: SqlObj a b -> b
sqlObjId (SqlObj _ y) = y
deriving instance Show (SqlObj a b)
......@@ -79,15 +94,18 @@ instance ToSqlCode (SqlObj a b) where
instance SqlIdContent SqlName
instance SqlIdContent (SqlName, SqlName)
instance ToSqlCode (SqlName, SqlName) where
toSqlCode (x, y) = toSqlCode (x <.> y)
instance SqlIdContent (SqlName, [SqlType])
instance ToSqlCode (SqlName, [SqlType]) where
toSqlCode (x, ys) =
toSqlCode x <> "(" <> T.intercalate ", " (map toSqlCode ys) <> ")"
instance SqlIdContent (SqlName, SqlName, SqlName)
instance ToSqlCode (SqlName, SqlName, SqlName) where
toSqlCode (x, _, y) = toSqlCode (x <.> y)
......@@ -117,21 +135,21 @@ expSqlName n = map SqlName (T.splitOn "." (getStr n))
instance ToSqlCode SqlType where
toSqlCode (SqlType n)
-- if quotes are contained
-- assume that user cares for correct enquoting
=
if '"' `isIn` n ||
-- if at least a pair of brakets is found
-- assume that a type like varchar(20) is meant
('(' `isIn` n && ')' `isIn` n) ||
-- if no dot is present, assume that buildin type
-- like integer is meant
not ('.' `isIn` n) ||
-- if % is present, assume that something like
-- table%ROWTYPE could be meant
'%' `isIn` n
then n
else toSqlCode' $ expSqlName $ SqlName n
| hasSquotes n || hasParenthesesPair n || hasNoDot n || hasPercent n = n
| otherwise = toSqlCode' $ expSqlName $ SqlName n
-- if quotes are contained
-- assume that user cares for correct enquoting
where
hasSquotes = isIn '"'
-- if at least a pair of brakets is found
-- assume that a type like varchar(20) is meant
hasParenthesesPair x = '(' `isIn` x && ')' `isIn` x
-- if no dot is present, assume that buildin type
-- like integer is meant
hasNoDot x = not ('.' `isIn` x)
-- if % is present, assume that something like
-- table%ROWTYPE could be meant
hasPercent = isIn '%'
instance SqlIdentifierConcat SqlType where
(//) (SqlType s) (SqlType t) = SqlType (s <> t)
......@@ -152,18 +170,20 @@ class ToSqlCode a where
class ToSqlName a where
toSqlName :: a -> SqlName
class SqlIdentifierConcat a where
class SqlIdentifierConcat a where
(//) :: a -> a -> a
instance Semigroup SqlName where
x@(SqlName x') <> y@(SqlName y')
| x == mempty = y
| y == mempty = x
| otherwise = SqlName (x' <> "_" <> y')
instance Monoid SqlName where
mempty = SqlName ""
mappend x@(SqlName x') y@(SqlName y')
| x == mempty = y
| y == mempty = x
| otherwise = SqlName (x' <> "_" <> y')
mappend = (<>)
-- SqlName
-- | SqlName
newtype SqlName =
SqlName Text
deriving (Generic, Ord, Show, Data)
......@@ -183,4 +203,3 @@ instance FromJSON SqlType where
instance ToJSON SqlType where
toJSON = toYamSqlJson
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