Dml.ag

{-
Copyright 2009 Jake Wheat

This file contains the type checking code for dml, currently insert,
update and delete.

================================================================================

= insert

check the insert data is the correct type. Doesn't cope with columns
with default values at the moment.

-}

SEM Statement
    | Insert
        loc.tpe =
            dependsOnRTpe [getTypeAnnotation @insData.annotatedTree] $ do
              @loc.columnTypes
              Right $ Pseudo Void
        loc.statementType =
            leftToEmpty (\ct -> [StatementType (getPlaceholderTypes @loc.insDataAddedInferredTypes) (fromMaybe [] @returning.listType)]) @loc.columnTypes

        loc.columnTypes =
            do
            tys <- unwrapSetOfComposite $
                   getTypeAnnotation @insData.annotatedTree
            checkColumnConsistency @lhs.cat
                                   @table
                                   @targetCols.strings
                                   tys
        loc.insDataAddedInferredTypes =
            case @insData.annotatedTree of
              Values ann [exl] ->
                  let fargs = map snd (fromRight [] @loc.columnTypes) ++ repeat TypeCheckFailed
                      newExl = map (\(ex,ty) -> updateAnnotation (++ [InferredType ty]) ex) $ zip exl fargs
                  in Values ann [newExl]
              x -> x

        loc.backTree = Insert @ann @table @targetCols.annotatedTree
                              @loc.insDataAddedInferredTypes @returning.annotatedTree
        loc.catUpdates = []

-- inject the ids into the returning part

SEM Statement
    | Insert
        returning.lib =
            fromRight @lhs.lib $ do
              atts <- catCompositeAttrs @lhs.cat relationComposites @table
              updateBindings @lhs.lib @lhs.cat [LibStackIDs [("", atts)]]

{-
================================================================================

= update

check the set clause assignments are ok, and inject ids into the where part

-}

SEM Statement
    | Update
        loc.tpe =
            do
            checkRelationExists @lhs.cat @table
            dependsOnRTpe (map snd @assigns.pairs) $ do
              @loc.columnTypes
              liftErrors @assigns.rowSetErrors
              return $ Pseudo Void
        loc.statementType =
            leftToEmpty (\ct -> [StatementType (getPlaceholderTypes @loc.assignWInferredTypes
                                                ++ getPlaceholderTypes @whr.annotatedTree)
                                               (fromMaybe [] @returning.listType)])
               @loc.columnTypes

        loc.columnTypes =
            checkColumnConsistency @lhs.cat
                                   @table
                                   (map fst @assigns.pairs)
                                   @assigns.pairs
        loc.assignWInferredTypes : SetClauseList
        loc.assignWInferredTypes =
            let colTypes :: [Type]
                colTypes = (map snd $ fromRight [] @loc.columnTypes)
            in setInferredTypesG colTypes @assigns.annotatedTree

        loc.backTree = Update @ann
                              @table
                              @loc.assignWInferredTypes
                              @whr.annotatedTree
                              @returning.annotatedTree
        loc.catUpdates = []

{

setInferredTypesG :: Data a => [Type] -> a -> a
setInferredTypesG tys x =
  evalState (transformBiM f x) tys
  where
    f (p@(Placeholder _)) = do
         y:ys <- get
         put ys
         return $ updateAnnotation (++ [InferredType y]) p
    f z = return z
}

-- local identifier bindings: pass the table attribute names and types
-- into the where expression, and the set clause expressions

SEM Statement
    | Update
        loc.lib =
             fromRight @lhs.lib $ do
             ct <- catCompositeAttrs @lhs.cat
                                     relationComposites
                                     @table
             updateBindings @lhs.lib @lhs.cat [LibStackIDs [("", ct)]]
        whr.lib = @loc.lib
        assigns.lib = @loc.lib
        returning.lib = @loc.lib

{-
== set clauses

small complication is slightly hacky code to deal with row set
assignments, where we assign from a multiple attribute subselect into
multiple columns - todo: check if we need so much special casing for
this: should be able to reuse the funcall typing of row set equality
(trade one hack for another, squinting so that assignment looks like
an equality check - since it type checks the same we might be ok). If
we do this, we only need to expand the row sets out to produce a
single string,type list at the end.

-}

ATTR SetClauseList [||pairs : {[(String,Type)]}
                      rowSetErrors : {[TypeError]}]

SEM SetClauseList
  | Cons lhs.pairs = @hd.pairs ++ @tl.pairs
         lhs.rowSetErrors = maybeToList @hd.rowSetError ++ @tl.rowSetErrors
  | Nil lhs.pairs = []
        lhs.rowSetErrors = []

ATTR SetClause [||pairs : {[(String,Type)]}
                  rowSetError : {Maybe TypeError}]

SEM SetClause
    | SetClause
        lhs.pairs = [(@att, getTypeAnnotation @val.annotatedTree)]
        lhs.rowSetError = Nothing
    | RowSetClause
        loc.rowSetError =
          let atts = @atts.strings
              types = getRowTypes @vals.typeList
          in if length atts /= length types
               then Just WrongNumberOfColumns
               else Nothing
        lhs.pairs = zip @atts.strings $ getRowTypes @vals.typeList

{
getRowTypes :: [Type] -> [Type]
getRowTypes [AnonymousRecordType ts] = ts
getRowTypes ts = ts
}

{-
================================================================================

= delete

pretty simple, mainly just need to inject ids into the where part

-}

SEM Statement
    | Delete
        loc.tpe =
            checkRelationExists @lhs.cat @table >>
            Right (Pseudo Void)
        loc.statementType = [StatementType (getPlaceholderTypes @whr.annotatedTree)
                                           (fromMaybe [] @returning.listType)]

        loc.backTree = Delete @ann @table @whr.annotatedTree @returning.annotatedTree
        loc.catUpdates = []


SEM Statement
    | Delete
        loc.lib =
            fromRight @lhs.lib $ do
            columnTypes <- catCompositeAttrs @lhs.cat relationComposites @table
            updateBindings @lhs.lib @lhs.cat [LibStackIDs [("", columnTypes)]]
        whr.lib = @loc.lib
        returning.lib = @loc.lib

{-
================================================================================
-}
{

--small shortcut to help produce better errors?
checkRelationExists :: Catalog -> String -> Either [TypeError] ()
checkRelationExists cat tbl =
    catCompositeDef cat relationComposites tbl >>
    return ()

--used by both insert and update
checkColumnConsistency :: Catalog ->  String -> [String] -> [(String,Type)]
                       -> Either [TypeError] [(String,Type)]
checkColumnConsistency cat tbl cols' insNameTypePairs = do
  ttcols <- lowerize <$> catCompositePublicAttrs cat [] tbl
  let cols = if null cols'
               then map fst ttcols
               else map (map toLower) cols'
  errorWhen (length insNameTypePairs /= length cols) [WrongNumberOfColumns]
  let nonMatchingColumns = cols \\ map fst ttcols
  errorWhen (not $ null nonMatchingColumns) $
       map UnrecognisedIdentifier nonMatchingColumns
  let targetNameTypePairs = map (\l -> (l,fromJust $ lookup l ttcols)) cols
        --check the types of the insdata match the column targets
        --name datatype columntype
      typeTriples = map (\((a,b),c) -> (a,b,c)) $
                    zip targetNameTypePairs $
                    map snd insNameTypePairs
      errs :: [TypeError]
      errs = concat $ lefts $
             map (\(_,b,c) -> checkAssignmentValid cat c b) typeTriples
  liftErrors errs
  return targetNameTypePairs
  where
    lowerize = map (\(a,b) -> (map toLower a,b))

}