module Database.Persist.Quasi
( parse
) where
import Database.Persist.Base
import Data.Char
import Data.Maybe (mapMaybe)
parse :: String -> [EntityDef]
parse = parse'
. removeSpaces
. filter (not . empty)
. map tokenize
. lines
data Token = Spaces !Int
| Token String
tokenize :: String -> [Token]
tokenize [] = []
tokenize ('-':'-':_) = []
tokenize ('"':xs) = go xs ""
where
go ('\"':rest) acc = Token (reverse acc) : tokenize rest
go ('\\':y:ys) acc = go ys (y:acc)
go (y:ys) acc = go ys (y:acc)
go [] acc = error $ "Unterminated quoted (\") string starting with " ++
show (reverse acc) ++ "."
tokenize (x:xs)
| isSpace x = let (spaces, rest) = span isSpace xs
in Spaces (1 + length spaces) : tokenize rest
tokenize xs = let (token, rest) = break isSpace xs
in Token token : tokenize rest
empty :: [Token] -> Bool
empty [] = True
empty [Spaces _] = True
empty _ = False
data Line = Line { lineType :: LineType
, tokens :: [String] }
data LineType = Header | Body
deriving (Eq)
removeSpaces :: [[Token]] -> [Line]
removeSpaces xs = map (makeLine . subtractSpace) xs
where
s = minimum $ map headSpace xs
headSpace (Spaces n : _) = n
headSpace _ = 0
subtractSpace ys | s == 0 = ys
subtractSpace (Spaces n : rest)
| n == s = rest
| otherwise = Spaces (n s) : rest
subtractSpace _ = error "Database.Persist.Quasi: never here"
getTokens (Token tok : rest) = tok : getTokens rest
getTokens (Spaces _ : rest) = getTokens rest
getTokens [] = []
makeLine (Spaces _ : rest) = Line Body (getTokens rest)
makeLine rest = Line Header (getTokens rest)
parse' :: [Line] -> [EntityDef]
parse' (Line Header (name:entattribs) : rest) =
let (x, y) = span ((== Body) . lineType) rest
in mkEntityDef name entattribs (map tokens x) : parse' y
parse' ((Line Header []) : _) = error "Indented line must contain at least name."
parse' ((Line Body _) : _) = error "Blocks must begin with non-indented lines."
parse' [] = []
mkEntityDef :: String -> [String] -> [[String]] -> EntityDef
mkEntityDef name entattribs attribs =
EntityDef name entattribs cols uniqs derives
where
cols = mapMaybe takeCols attribs
uniqs = mapMaybe takeUniqs attribs
derives = case mapMaybe takeDerives attribs of
[] -> ["Show", "Read", "Eq"]
x -> concat x
takeCols :: [String] -> Maybe ColumnDef
takeCols ("deriving":_) = Nothing
takeCols (n@(f:_):ty:rest)
| isLower f = Just $ ColumnDef n ty rest
takeCols _ = Nothing
takeUniqs :: [String] -> Maybe UniqueDef
takeUniqs (n@(f:_):rest)
| isUpper f = Just $ UniqueDef n rest
takeUniqs _ = Nothing
takeDerives :: [String] -> Maybe [String]
takeDerives ("deriving":rest) = Just rest
takeDerives _ = Nothing