module Database.Persist.Quasi
( parse
, PersistSettings (..)
, upperCaseSettings
, lowerCaseSettings
, stripId
, nullable
#if TEST
, Token (..)
, tokenize
, parseFieldType
#endif
) where
import Prelude hiding (lines)
import Database.Persist.Types
import Data.Char
import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
import Data.Text (Text)
import qualified Data.Text as T
import Control.Arrow ((&&&))
import qualified Data.Map as M
import Data.List (foldl',find)
import Data.Monoid (mappend)
data ParseState a = PSDone | PSFail | PSSuccess a Text
parseFieldType :: Text -> Maybe FieldType
parseFieldType t0 =
case go t0 of
PSSuccess ft t'
| T.all isSpace t' -> Just ft
_ -> Nothing
where
go t =
case goMany id t of
PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t'
PSSuccess [] _ -> PSFail
PSFail -> PSFail
PSDone -> PSDone
go1 t =
case T.uncons t of
Nothing -> PSDone
Just (c, t')
| isSpace c -> go1 $ T.dropWhile isSpace t'
| c == '(' ->
case go t' of
PSSuccess ft t'' ->
case T.uncons $ T.dropWhile isSpace t'' of
Just (')', t''') -> PSSuccess ft t'''
_ -> PSFail
_ -> PSFail
| c == '[' ->
case go t' of
PSSuccess ft t'' ->
case T.uncons $ T.dropWhile isSpace t'' of
Just (']', t''') -> PSSuccess (FTList ft) t'''
_ -> PSFail
_ -> PSFail
| isUpper c ->
let (a, b) = T.break (\x -> isSpace x || x `elem` "()[]") t
in PSSuccess (getCon a) b
| otherwise -> PSFail
getCon t =
case T.breakOnEnd "." t of
(_, "") -> FTTypeCon Nothing t
("", _) -> FTTypeCon Nothing t
(a, b) -> FTTypeCon (Just $ T.init a) b
goMany front t =
case go1 t of
PSSuccess x t' -> goMany (front . (x:)) t'
_ -> PSSuccess (front []) t
data PersistSettings = PersistSettings
{ psToDBName :: !(Text -> Text)
, psStrictFields :: !Bool
}
upperCaseSettings :: PersistSettings
upperCaseSettings = PersistSettings
{ psToDBName = id
, psStrictFields = True
}
lowerCaseSettings :: PersistSettings
lowerCaseSettings = PersistSettings
{ psToDBName =
let go c
| isUpper c = T.pack ['_', toLower c]
| otherwise = T.singleton c
in T.dropWhile (== '_') . T.concatMap go
, psStrictFields = True
}
parse :: PersistSettings -> Text -> [EntityDef ()]
parse ps = parseLines ps
. removeSpaces
. filter (not . empty)
. map tokenize
. T.lines
data Token = Spaces !Int
| Token Text
deriving (Show, Eq)
tokenize :: Text -> [Token]
tokenize t
| T.null t = []
| "--" `T.isPrefixOf` t = []
| "#" `T.isPrefixOf` t = []
| T.head t == '"' = quotes (T.tail t) id
| T.head t == '(' = parens 1 (T.tail t) id
| isSpace (T.head t) =
let (spaces, rest) = T.span isSpace t
in Spaces (T.length spaces) : tokenize rest
| Just (beforeEquals, afterEquals) <- findMidToken t
, not (T.any isSpace beforeEquals)
, Token next : rest <- tokenize afterEquals =
Token (T.concat [beforeEquals, "=", next]) : rest
| otherwise =
let (token, rest) = T.break isSpace t
in Token token : tokenize rest
where
findMidToken t' =
case T.break (== '=') t' of
(x, T.drop 1 -> y)
| "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y)
_ -> Nothing
quotes t' front
| T.null t' = error $ T.unpack $ T.concat $
"Unterminated quoted string starting with " : front []
| T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t')
| T.head t' == '\\' && T.length t' > 1 =
quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):))
| otherwise =
let (x, y) = T.break (`elem` "\\\"") t'
in quotes y (front . (x:))
parens count t' front
| T.null t' = error $ T.unpack $ T.concat $
"Unterminated parens string starting with " : front []
| T.head t' == ')' =
if count == (1 :: Int)
then Token (T.concat $ front []) : tokenize (T.tail t')
else parens (count 1) (T.tail t') (front . (")":))
| T.head t' == '(' =
parens (count + 1) (T.tail t') (front . ("(":))
| T.head t' == '\\' && T.length t' > 1 =
parens count (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):))
| otherwise =
let (x, y) = T.break (`elem` "\\()") t'
in parens count y (front . (x:))
empty :: [Token] -> Bool
empty [] = True
empty [Spaces _] = True
empty _ = False
data Line = Line { lineIndent :: Int
, tokens :: [Text]
}
removeSpaces :: [[Token]] -> [Line]
removeSpaces =
map toLine
where
toLine (Spaces i:rest) = toLine' i rest
toLine xs = toLine' 0 xs
toLine' i = Line i . mapMaybe fromToken
fromToken (Token t) = Just t
fromToken Spaces{} = Nothing
parseLines :: PersistSettings -> [Line] -> [EntityDef ()]
parseLines ps lines =
fixForeignKeysAll $ toEnts lines
where
toEnts (Line indent (name:entattribs) : rest) =
let (x, y) = span ((> indent) . lineIndent) rest
in mkEntityDef ps name entattribs x : toEnts y
toEnts (Line _ []:rest) = toEnts rest
toEnts [] = []
fixForeignKeysAll :: [EntityDef ()] -> [EntityDef ()]
fixForeignKeysAll ents = map fixForeignKeys ents
where fixForeignKeys :: EntityDef () -> EntityDef ()
fixForeignKeys ent = ent { entityForeigns = map (fixForeignKey ent) (entityForeigns ent) }
chktypes :: [FieldDef ()] -> HaskellName -> [FieldDef ()] -> HaskellName -> Bool
chktypes fflds fkey pflds pkey = case (filter ((== fkey) . fieldHaskell) fflds, filter ((== pkey) . fieldHaskell) pflds) of
([ffld],[pfld]) -> fieldType ffld == fieldType pfld
xs -> error $ "unexpected result "++ show xs
fixForeignKey :: EntityDef () -> ForeignDef -> ForeignDef
fixForeignKey fent fdef =
case find ((== foreignRefTableHaskell fdef) . entityHaskell) ents of
Just pent -> case entityPrimary pent of
Just pdef -> if length (foreignFields fdef) == length (primaryFields pdef)
then fdef { foreignFields = zipWith (\(a,b,_,_) (a',b') ->
if chktypes (entityFields fent) a (entityFields pent) a'
then (a,b,a',b')
else error ("type mismatch between foreign key and primary column" ++ show (a,a') ++ " primary ent="++show pent ++ " foreign ent="++show fent)) (foreignFields fdef) (primaryFields pdef) }
else error $ "found " ++ show (length (foreignFields fdef)) ++ " fkeys and " ++ show (length (primaryFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef
Nothing -> error $ "no explicit primary key fdef="++show fdef++ " fent="++show fent
Nothing -> error $ "could not find table " ++ show (foreignRefTableHaskell fdef) ++ " fdef=" ++ show fdef ++ " allnames=" ++ show (map (unHaskellName . entityHaskell) ents) ++ "\n\nents=" ++ show ents
mkEntityDef :: PersistSettings
-> Text
-> [Attr]
-> [Line]
-> EntityDef ()
mkEntityDef ps name entattribs lines =
EntityDef
(HaskellName name')
(DBName $ getDbName ps name' entattribs)
(DBName $ idName entattribs)
entattribs cols primary uniqs foreigns derives
extras
isSum
where
(isSum, name') =
case T.uncons name of
Just ('+', x) -> (True, x)
_ -> (False, name)
(attribs, extras) = splitExtras lines
idName [] = "id"
idName (t:ts) =
case T.stripPrefix "id=" t of
Nothing -> idName ts
Just s -> s
(primarys, uniqs, foreigns) = foldl' (\(a,b,c) attr ->
let (a',b',c') = takeConstraint ps name' cols attr
squish xs m = xs `mappend` maybeToList m
in (squish a a', squish b b', squish c c')) ([],[],[]) attribs
primary = case primarys of
[] -> Nothing
[p] -> Just p
_ -> error $ "found more than one primary key in table[" ++ show name' ++ "]"
derives = concat $ mapMaybe takeDerives attribs
cols :: [FieldDef ()]
cols = mapMaybe (takeCols ps) attribs
splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]])
splitExtras [] = ([], M.empty)
splitExtras (Line indent [name]:rest)
| not (T.null name) && isUpper (T.head name) =
let (children, rest') = span ((> indent) . lineIndent) rest
(x, y) = splitExtras rest'
in (x, M.insert name (map tokens children) y)
splitExtras (Line _ ts:rest) =
let (x, y) = splitExtras rest
in (ts:x, y)
takeCols :: PersistSettings -> [Text] -> Maybe (FieldDef ())
takeCols _ ("deriving":_) = Nothing
takeCols ps (n':typ:rest)
| not (T.null n) && isLower (T.head n) =
case parseFieldType typ of
Nothing -> error $ "Invalid field type: " ++ show typ
Just ft -> Just FieldDef
{ fieldHaskell = HaskellName n
, fieldDB = DBName $ getDbName ps n rest
, fieldType = ft
, fieldSqlType = ()
, fieldAttrs = rest
, fieldStrict = fromMaybe (psStrictFields ps) mstrict
, fieldEmbedded = Nothing
}
where
(mstrict, n)
| Just x <- T.stripPrefix "!" n' = (Just True, x)
| Just x <- T.stripPrefix "~" n' = (Just False, x)
| otherwise = (Nothing, n')
takeCols _ _ = Nothing
getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName ps n [] = psToDBName ps n
getDbName ps n (a:as) =
case T.stripPrefix "sql=" a of
Nothing -> getDbName ps n as
Just s -> s
takeConstraint :: PersistSettings
-> Text
-> [FieldDef a]
-> [Text]
-> (Maybe PrimaryDef, Maybe UniqueDef, Maybe ForeignDef)
takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint'
where takeConstraint'
| n == "Primary" = (Just $ takePrimary defs rest, Nothing, Nothing)
| n == "Unique" = (Nothing, Just $ takeUniq ps tableName defs rest, Nothing)
| n == "Foreign" = (Nothing, Nothing, Just $ takeForeign ps tableName defs rest)
| otherwise = (Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing)
takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing)
takePrimary :: [FieldDef a]
-> [Text]
-> PrimaryDef
takePrimary defs pkcols
= PrimaryDef
(map (HaskellName &&& getDBName defs) pkcols)
attrs
where
(_, attrs) = break ("!" `T.isPrefixOf`) pkcols
getDBName [] t = error $ "Unknown column in primary key constraint: " ++ show t
getDBName (d:ds) t
| nullable (fieldAttrs d) /= NotNullable = error $ "primary key column cannot be nullable: " ++ show t
| fieldHaskell d == HaskellName t = fieldDB d
| otherwise = getDBName ds t
takeUniq :: PersistSettings
-> Text
-> [FieldDef a]
-> [Text]
-> UniqueDef
takeUniq ps tableName defs (n:rest)
| not (T.null n) && isUpper (T.head n)
= UniqueDef
(HaskellName n)
(DBName $ psToDBName ps (tableName `T.append` n))
(map (HaskellName &&& getDBName defs) fields)
attrs
where
(fields,attrs) = break ("!" `T.isPrefixOf`) rest
getDBName [] t = error $ "Unknown column in unique constraint: " ++ show t
getDBName (d:ds) t
| fieldHaskell d == HaskellName t = fieldDB d
| otherwise = getDBName ds t
takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName ++ "] expecting an uppercase constraint name xs=" ++ show xs
takeForeign :: PersistSettings
-> Text
-> [FieldDef a]
-> [Text]
-> ForeignDef
takeForeign ps tableName defs (refTableName:n:rest)
| not (T.null n) && isLower (T.head n)
= ForeignDef
(HaskellName refTableName)
(DBName $ psToDBName ps refTableName)
(HaskellName n)
(DBName $ psToDBName ps (tableName `T.append` n))
(map (\f -> (HaskellName f, getDBName defs f, HaskellName "", DBName "")) fields)
attrs
where
(fields,attrs) = break ("!" `T.isPrefixOf`) rest
getDBName [] t = error $ "Unknown column in foreign key constraint: " ++ show t
getDBName (d:ds) t
| nullable (fieldAttrs d) /= NotNullable = error $ "foreign key column cannot be nullable: " ++ show t
| fieldHaskell d == HaskellName t = fieldDB d
| otherwise = getDBName ds t
takeForeign _ tableName _ xs = error $ "invalid foreign key constraint on table[" ++ show tableName ++ "] expecting a lower case constraint name xs=" ++ show xs
takeDerives :: [Text] -> Maybe [Text]
takeDerives ("deriving":rest) = Just rest
takeDerives _ = Nothing
stripId :: FieldType -> Maybe Text
stripId (FTTypeCon Nothing t) = T.stripSuffix "Id" t
stripId _ = Nothing
nullable :: [Text] -> IsNullable
nullable s
| "Maybe" `elem` s = Nullable ByMaybeAttr
| "nullable" `elem` s = Nullable ByNullableAttr
| otherwise = NotNullable