<commit_before>module Parse.Types where

import Ast
import Control.Applicative ((<$>),(<*>))
import Control.Monad (liftM,mapM)
import Data.Char (isUpper,isLower)
import Data.Maybe (fromMaybe)
import Data.List (lookup)
import Text.Parsec
import Text.Parsec.Indent

import Parse.Library
import Types.Types hiding (string,parens)
import Guid

data ParseType = VarPT String
               | LambdaPT ParseType ParseType
               | ADTPT String [ParseType]
               | RecordPT [(String,ParseType)]

listPT t = ADTPT "List" [t]
tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts

typeVar :: IParser ParseType
typeVar = VarPT <$> lowVar <?> "type variable"

typeList :: IParser ParseType
typeList  = listPT <$> braces typeExpr

typeTuple :: IParser ParseType
typeTuple = do ts <- parens (commaSep typeExpr)
               return $ case ts of { [t] -> t ; _ -> tuplePT ts }

typeRecord :: IParser ParseType
typeRecord = fmap RecordPT . brackets . commaSep $ do
               lbl <- rLabel
               whitespace >> hasType >> whitespace
               (,) lbl <$> typeExpr

typeUnambiguous :: IParser ParseType
typeUnambiguous = typeList <|> typeTuple <|> typeRecord

typeSimple :: IParser ParseType
typeSimple = dealias <$> var
    where dealias "String" = listPT (VarPT "Char")
          dealias "Time" = VarPT "Float"
          dealias v = VarPT v

typeApp :: IParser ParseType
typeApp = do name <- capVar <?> "type constructor"
             args <- spacePrefix (typeUnambiguous <|> typeSimple)
             return $ case args of
                        [] -> VarPT name
                        _  -> ADTPT name args

typeExpr :: IParser ParseType
typeExpr = do
  t1 <- typeVar <|> typeApp <|> typeUnambiguous
  whitespace ; arr <- optionMaybe arrow ; whitespace
  case arr of
    Just _  -> LambdaPT t1 <$> typeExpr
    Nothing -> return t1

typeConstructor :: IParser (String, [ParseType])
typeConstructor = (,) <$> (capVar <?> "another type constructor")
                      <*> spacePrefix (typeSimple <|> typeUnambiguous)

typeAlias :: IParser Statement
typeAlias = do
  reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
  forcedWS
  alias <- capVar
  args  <- spacePrefix lowVar
  whitespace ; string "=" ; whitespace
  let n = length args
  tipe <- typeExpr
  case toTypeWith alias (zip args [1..n]) tipe of
    Right t -> return (TypeAlias alias [1..n] t)
    Left msg -> fail msg

typeAnnotation :: IParser Statement
typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
    where start = do v <- lowVar <|> parens symOp
                     whitespace ; hasType ; whitespace ; return v

datatype :: IParser Statement
datatype = do
  reserved "data" <?> "datatype definition (data T = A | B | ...)"
  forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar
  whitespace ; string "=" ; whitespace
  tcs <- pipeSep1 typeConstructor
  case toDatatype name args tcs of
    Right dt -> return dt
    Left msg -> fail msg

beta = liftM VarT guid

toType :: ParseType -> Type
toType pt =
  let frees :: ParseType -> [String]
      frees pt = case pt of
                   LambdaPT a b -> frees a ++ frees b
                   ADTPT _ ts   -> concatMap frees ts
                   RecordPT fs  -> concatMap (frees . snd) fs
                   VarPT (c:cs) | isLower c -> [c:cs]
                                | otherwise -> []
  in  case toTypeWith "" (zip (frees pt) [1..]) pt of
        Right t -> t
        Left  _ -> VarT 0

toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type
toTypeWith name tvarDict pt =
  let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."
      toT = toTypeWith name tvarDict
  in  case pt of
        LambdaPT t1 t2  -> (==>) <$> toT t1 <*> toT t2
        ADTPT name args -> ADT name <$> mapM toT args
        RecordPT fs     -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
                              return (RecordT (recordT fs') EmptyRecord)
        VarPT x@(c:_)
            | not (isLower c) -> return $ ADT x []
            | otherwise -> VarT <$> case lookup x tvarDict of
                                      Just v -> Right v
                                      Nothing -> Left (msg x)


toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs
    where n = length args
          toType = toTypeWith name (zip args [1..n])
          toC (name,pt) = (,) name <$> mapM toType pt


toForeignType (LambdaPT t1 t2) =
    fail $ "Elm's JavaScript event interface does not yet handle functions. " ++
           "Only simple values can be imported and exported in this release."
    --LambdaT <$> toForeignType t1 <*> toForeignType t2
toForeignType (ADTPT name args)
    | isJsStructure name =  ADT name <$> mapM toForeignType args
    | otherwise =
        Left $ "'" ++ name ++ "' is not an exportable type " ++
               "constructor. Only 'JSArray' and 'JSTupleN' are exportable."

toForeignType (VarPT x@(c:_))
    | isLower c =
        Left "All exported types must be concrete types (JSNumber, JSString, etc.)"
    | x `elem` ["JSString","JSNumber","JSElement","JSBool"] = Right (ADT x [])
    | otherwise = Left $ "'" ++ x ++ "' is not an exportable type. Only JSTypes are exportable."
<commit_msg>Allow record extension in types.<commit_after>module Parse.Types where

import Ast
import Control.Applicative ((<$>),(<*>))
import Control.Monad (liftM,mapM)
import Data.Char (isUpper,isLower)
import Data.Maybe (fromMaybe)
import Data.List (lookup)
import Text.Parsec
import Text.Parsec.Indent

import Parse.Library
import Types.Types hiding (string,parens)
import Guid

data ParseType = VarPT String
               | LambdaPT ParseType ParseType
               | ADTPT String [ParseType]
               | RecordPT (Maybe ParseType) [(String,ParseType)]

listPT t = ADTPT "List" [t]
tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts

typeVar :: IParser ParseType
typeVar = VarPT <$> lowVar <?> "type variable"

typeList :: IParser ParseType
typeList  = listPT <$> braces typeExpr

typeTuple :: IParser ParseType
typeTuple = do ts <- parens (commaSep typeExpr)
               return $ case ts of { [t] -> t ; _ -> tuplePT ts }

typeRecord :: IParser ParseType
typeRecord = brackets (RecordPT <$> extend <*> fields)
  where extend = optionMaybe . try $ do
                   t <- typeVar
                   whitespace >> string "|" >> whitespace
                   return t
        fields = commaSep $ do
                   lbl <- rLabel
                   whitespace >> hasType >> whitespace
                   (,) lbl <$> typeExpr

typeUnambiguous :: IParser ParseType
typeUnambiguous = typeList <|> typeTuple <|> typeRecord

typeSimple :: IParser ParseType
typeSimple = dealias <$> var
    where dealias "String" = listPT (VarPT "Char")
          dealias "Time" = VarPT "Float"
          dealias v = VarPT v

typeApp :: IParser ParseType
typeApp = do name <- capVar <?> "type constructor"
             args <- spacePrefix (typeUnambiguous <|> typeSimple)
             return $ case args of
                        [] -> VarPT name
                        _  -> ADTPT name args

typeExpr :: IParser ParseType
typeExpr = do
  t1 <- typeVar <|> typeApp <|> typeUnambiguous
  whitespace ; arr <- optionMaybe arrow ; whitespace
  case arr of
    Just _  -> LambdaPT t1 <$> typeExpr
    Nothing -> return t1

typeConstructor :: IParser (String, [ParseType])
typeConstructor = (,) <$> (capVar <?> "another type constructor")
                      <*> spacePrefix (typeSimple <|> typeUnambiguous)

typeAlias :: IParser Statement
typeAlias = do
  reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
  forcedWS
  alias <- capVar
  args  <- spacePrefix lowVar
  whitespace ; string "=" ; whitespace
  let n = length args
  tipe <- typeExpr
  case toTypeWith alias (zip args [1..n]) tipe of
    Right t -> return (TypeAlias alias [1..n] t)
    Left msg -> fail msg

typeAnnotation :: IParser Statement
typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
    where start = do v <- lowVar <|> parens symOp
                     whitespace ; hasType ; whitespace ; return v

datatype :: IParser Statement
datatype = do
  reserved "data" <?> "datatype definition (data T = A | B | ...)"
  forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar
  whitespace ; string "=" ; whitespace
  tcs <- pipeSep1 typeConstructor
  case toDatatype name args tcs of
    Right dt -> return dt
    Left msg -> fail msg

beta = liftM VarT guid

toType :: ParseType -> Type
toType pt =
  let frees :: ParseType -> [String]
      frees pt = case pt of
                   LambdaPT a b  -> frees a ++ frees b
                   ADTPT _ ts    -> concatMap frees ts
                   RecordPT t fs -> maybe [] frees t ++ concatMap (frees . snd) fs
                   VarPT (c:cs) | isLower c -> [c:cs]
                                | otherwise -> []
  in  case toTypeWith "" (zip (frees pt) [1..]) pt of
        Right t -> t
        Left  _ -> VarT 0

toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type
toTypeWith name tvarDict pt =
  let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."
      toT = toTypeWith name tvarDict
  in  case pt of
        LambdaPT t1 t2  -> (==>) <$> toT t1 <*> toT t2
        ADTPT name args -> ADT name <$> mapM toT args
        RecordPT t fs   -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
                              ext <- maybe (return EmptyRecord) toT t
                              return (RecordT (recordT fs') ext)
        VarPT x@(c:_)
            | not (isLower c) -> return $ ADT x []
            | otherwise -> VarT <$> case lookup x tvarDict of
                                      Just v -> Right v
                                      Nothing -> Left (msg x)


toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs
    where n = length args
          toType = toTypeWith name (zip args [1..n])
          toC (name,pt) = (,) name <$> mapM toType pt


toForeignType (LambdaPT t1 t2) =
    fail $ "Elm's JavaScript event interface does not yet handle functions. " ++
           "Only simple values can be imported and exported in this release."
    --LambdaT <$> toForeignType t1 <*> toForeignType t2
toForeignType (ADTPT name args)
    | isJsStructure name =  ADT name <$> mapM toForeignType args
    | otherwise =
        Left $ "'" ++ name ++ "' is not an exportable type " ++
               "constructor. Only 'JSArray' and 'JSTupleN' are exportable."

toForeignType (VarPT x@(c:_))
    | isLower c =
        Left "All exported types must be concrete types (JSNumber, JSString, etc.)"
    | x `elem` ["JSString","JSNumber","JSElement","JSBool"] = Right (ADT x [])
    | otherwise = Left $ "'" ++ x ++ "' is not an exportable type. Only JSTypes are exportable."

{'fraction_non_alphanumeric': 0.11520058888479941, 'fraction_numerical': 0.003312476996687523, 'mean_word_length': 2.251271313191744, 'pattern_counts': {'":': 0, '<': 105, '<?xml version=': 0, '>': 149, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 9, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7520153', 'n_tokens_mistral': 3357, 'n_tokens_neox': 3253, 'n_words': 1141}