<commit_before>{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Database.Persist.Quasi
    ( parse
    , PersistSettings (..)
    , upperCaseSettings
    , lowerCaseSettings
#if TEST
    , Token (..)
    , tokenize
    , parseFieldType
#endif
    ) where

import Prelude hiding (lines)
import Database.Persist.EntityDef
import Data.Char
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Control.Arrow ((&&&))
import qualified Data.Map as M
import Data.List (foldl')

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
    }

upperCaseSettings :: PersistSettings
upperCaseSettings = PersistSettings
    { psToDBName = id
    }

lowerCaseSettings :: PersistSettings
lowerCaseSettings = PersistSettings
    { psToDBName =
        let go c
                | isUpper c = T.pack ['_', toLower c]
                | otherwise = T.singleton c
         in T.dropWhile (== '_') . T.concatMap go
    }

-- | Parses a quasi-quoted syntax into a list of entity definitions.
parse :: PersistSettings -> Text -> [EntityDef]
parse ps = parseLines ps
      . removeSpaces
      . filter (not . empty)
      . map tokenize
      . T.lines

-- | A token used by the parser.
data Token = Spaces !Int   -- ^ @Spaces n@ are @n@ consecutive spaces.
           | Token Text    -- ^ @Token tok@ is token @tok@ already unquoted.
  deriving (Show, Eq)

-- | Tokenize a string.
tokenize :: Text -> [Token]
tokenize t
    | T.null t = []
    | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line.
    | 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
    | otherwise =
        let (token, rest) = T.break isSpace t
         in Token token : tokenize rest
  where
    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 =<commit_msg>Ignore # in persist declarations (#110)<commit_after>{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Database.Persist.Quasi
    ( parse
    , PersistSettings (..)
    , upperCaseSettings
    , lowerCaseSettings
#if TEST
    , Token (..)
    , tokenize
    , parseFieldType
#endif
    ) where

import Prelude hiding (lines)
import Database.Persist.EntityDef
import Data.Char
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Control.Arrow ((&&&))
import qualified Data.Map as M
import Data.List (foldl')

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
    }

upperCaseSettings :: PersistSettings
upperCaseSettings = PersistSettings
    { psToDBName = id
    }

lowerCaseSettings :: PersistSettings
lowerCaseSettings = PersistSettings
    { psToDBName =
        let go c
                | isUpper c = T.pack ['_', toLower c]
                | otherwise = T.singleton c
         in T.dropWhile (== '_') . T.concatMap go
    }

-- | Parses a quasi-quoted syntax into a list of entity definitions.
parse :: PersistSettings -> Text -> [EntityDef]
parse ps = parseLines ps
      . removeSpaces
      . filter (not . empty)
      . map tokenize
      . T.lines

-- | A token used by the parser.
data Token = Spaces !Int   -- ^ @Spaces n@ are @n@ consecutive spaces.
           | Token Text    -- ^ @Token tok@ is token @tok@ already unquoted.
  deriving (Show, Eq)

-- | Tokenize a string.
tokenize :: Text -> [Token]
tokenize t
    | T.null t = []
    | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line.
    | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110)
    | 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
    | otherwise =
        let (token, rest) = T.break isSpace t
         in Token token : tokenize rest
  where
    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 =
{'fraction_non_alphanumeric': 0.11873285108505861, 'fraction_numerical': 0.002494387627837366, 'mean_word_length': 1.504372267332917, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 67, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3381880', 'n_tokens_mistral': 2496, 'n_tokens_neox': 2410, 'n_words': 788}